Type Mismatch Error on Range in For Each loop

Question

I would like to use an entire column as my range for my code, but I keep running to Type Mismatch error, This is my Code.

            Dim xRgDate As Range
            Dim xCellDate As Range
            Set xRgDate = Range("E:E")
            For Each xCellDate In xRgDate
                If Not IsEmpty(xCellDate) Then
                    xMonth = Month(xCellDate.Value)
                    xMonthName = MonthName(xMonth)
                    If Len(Dir((FPath & "\" & ws.Name & "\" & xMonthName), vbDirectory)) = 0 Then
                    MkDir (FPath & "\" & ws.Name & "\" & xMonthName)
                    End If
                End If
            Next xCellDate

I keep trying to change the Range Selection, for example this works but it's not the entire column

 Set xRgDate = Range("E9:E40")

This is the full code

Sub SplitEachMonthToSubFodlers()

    Dim FPath As String
    FPath = Application.ActiveWorkbook.Path
    For Each ws In ThisWorkbook.Sheets
        If Len(Dir((FPath & "\" & ws.Name), vbDirectory)) = 0 Then
            MkDir (FPath & "\" & ws.Name)
            
            Dim xRgDate As Range
            Dim xCellDate As Range
            Set xRgDate = ws.Range("E9:E40")
            For Each xCellDate In xRgDate
                If Not IsEmpty(xCellDate) Then
                    xMonth = Month(xCellDate.Value)
                    xMonthName = MonthName(xMonth)
                    If Len(Dir((FPath & "\" & ws.Name & "\" & xMonthName), vbDirectory)) = 0 Then
                    MkDir (FPath & "\" & ws.Name & "\" & xMonthName)
                    End If
                End If
            Next xCellDate
        Else
        MsgBox ("Folders Already Existed")
        End If
    Next ws
    MsgBox ("Folders Created")
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

Answer 1

Create Monthly Subfolders

Option Explicit

Sub CreateMonthlySubFolders()
    Const PROC_TITLE As String = "Create Monthly Subfolders"
    On Error GoTo ClearError
    
    Const FIRST_CELL As String = "E9"
     
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim pSep As String: pSep = Application.PathSeparator
    Dim FolderPath As String: FolderPath = wb.Path & pSep
    
    If Len(FolderPath) = 1 Then
        MsgBox "The file """ & wb.Name & """ hasn't been saved yet.", _
            vbCritical, PROC_TITLE
        Exit Sub
    End If
    
    Dim ws As Worksheet, rg As Range
    Dim Data(), cValue, fCount As Long, rCount As Long, r As Long
    Dim SubPathLevel1 As String, SubPathLevel2 As String, MonthString As String
    
    For Each ws In wb.Worksheets
        
        SubPathLevel1 = FolderPath & ws.Name
        If Len(Dir(SubPathLevel1, vbDirectory)) = 0 Then ' doesn't exist
           MkDir SubPathLevel1
           fCount = fCount + 1
        'Else ' the folder already exists; do nothing
        End If
        
        With ws.Range(FIRST_CELL)
            Set rg = Intersect(.Resize(ws.Rows.Count - .Row + 1), ws.UsedRange)
        End With
        
        If Not rg Is Nothing Then ' the column range is not empty
            rCount = rg.Rows.Count
            If rCount = 1 Then
                ReDim Data(1 To 1, 1 To 1): Data(1, 1) = rg.Value
            Else
                Data = rg.Value
            End If
            For r = 1 To rCount
                cValue = Data(r, 1)
                If IsDate(cValue) Then ' it's a date
                    MonthString = MonthName(Month(cValue))
                    SubPathLevel2 = SubPathLevel1 & pSep & MonthString
                    If Len(Dir(SubPathLevel2, vbDirectory)) = 0 Then ' doesn't
                        MkDir SubPathLevel2
                        fCount = fCount + 1
                    'Else ' the folder already exists; do nothing
                    End If
                'Else ' it's not a date; do nothing
                End If
            Next r
        'Else ' the column range is empty; do nothing
        End If
    
    Next ws
    
    If fCount = 0 Then
        MsgBox "All subfolders had already been created.", _
            vbExclamation, PROC_TITLE
    Else
        MsgBox fCount & " subfolder" & IIf(fCount = 1, "", "s") & " created.", _
            vbInformation, PROC_TITLE
    End If

ProcExit:
    Exit Sub
ClearError:
    MsgBox "Run-time error '" & Err.Number & "':" & vbLf & vbLf _
        & Err.Description, vbCritical, PROC_TITLE
    Resume ProcExit
End Sub