Search subfolders

[Joe9238]

Hi, I have a piece of code that copies and pastes data from files in a selected folder. The problem is that when incorporating sub-folders, it won't work saying 'runtime error 13 type mismatch'. Is there a way to include sub folders in this?

 Option ExplicitSub GatherData()
Range("A1").Value = "Quoted By"
Range("B1").Value = "Quoted On"
Range("C1").Value = "Client Name"
Range("D1").Value = "Email Address"




Dim sFolder As String


    Application.ScreenUpdating = True
    
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = Application.DefaultFilePath & "\"
        .Title = "Please select a folder..."
        .Show
        If .SelectedItems.Count > 0 Then
            sFolder = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    Call Consolidate(sFolder, ThisWorkbook)
End Sub
Private Sub Consolidate(sFolder As String, wbMaster As Workbook)
    Dim wbTarget As Workbook
    Dim ary(4) As Variant
    Dim lRow As Long
    Dim objFile As Object
    Dim objFso As Object
    Dim objFiles As Object
        Dim objSubFolders As Object
        Dim objSubFolder As Object
    
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objFiles = objFso.GetFolder(sFolder).Files




Dim CodeNames As Variant, i As Long
CodeNames = Range("A2:A" & Cells(Rows.Count, "A").End(xlUp).Row)




For Each objFile In objFiles
For i = 1 To UBound(CodeNames, 1)
If objFile.Name Like "*" & CodeNames(i, 1) & "*" Then




    'Create objects to enumerate files and folders
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objSubFolders = objFso.GetFolder(sFolder).SubFolders
    Set objFiles = objFso.GetFolder(sFolder).Files




    'Loop through each file in the folder
        If InStr(1, objFile.Path, ".xls") > 0 Then
            Set wbTarget = Workbooks.Open(objFile.Path)
            With wbTarget.Worksheets("Quote")
                ary(0) = .Range("B7")
                ary(1) = .Range("B8")
                ary(2) = .Range("B11")
                ary(3) = .Range("B13")
            End With
            
            With wbMaster.Worksheets(1)
                lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
                .Range("A" & lRow & ":D" & lRow) = ary
            End With
            
            wbTarget.Close savechanges:=False
        End If




    'Request count of files in subfolders
    For Each objSubFolder In objSubFolders
        Consolidate objSubFolder.Path, wbMaster
    Next objSubFolder




    Exit For
    
End If
Next i
Next objFile




End Sub

The line highlighted with the error is

For i = 1 To UBound(CodeNames, 1)

Thanks in advance