Recursive code to extract data from multiple subfolders

Question

The below code extracts data from multiple workbooks in a folder.

My question is, other files are located in the same drive but in a subfolder.

How to extract them with the below code?

For example.

Z>My Items>Reports>June Folder>Team A Folder> (workbooks 1-10)
Z>My Items>Reports>June Folder>Team B Folder (workbooks 11-20)
Z>My Items>Reports>June Folder>Team C Folder (workbooks 21-30)

All workbooks are located in Drive Z>My items>Reports folder.

Public Sub Copy_AutoFiltered_Rows_From_Workbooks()

    Dim matchFiles As String, folder As String, fileName As String
    Dim destCell As Range
    Dim fromWorkbook As Workbook
    Dim startDate As Date, endDate As Date
   
    'Folder and wildcard file spec of workbooks to import
   
    matchFiles = "C:\Users\Tim\Desktop\My Files\*.xlsm"
    'matchFiles = "D:\Temp\Excel\Workbooks\Draft*.xlsm"
    folder = Left(matchFiles, InStrRev(matchFiles, "\"))
   
    With ThisWorkbook.ActiveSheet
        If Not IsDate(.Range("A1").Value) Or IsEmpty(.Range("A1").Value) Or Not IsDate(.Range("A2").Value) Or IsEmpty(.Range("A2").Value) Then
            MsgBox "Cells A1 and A2 must contain a date"
            Exit Sub
        End If
        startDate = .Range("A1").Value
        endDate = .Range("A2").Value
        If startDate > endDate Then
            MsgBox "Start date in A1 must be earlier than end date in A2"
            Exit Sub
        End If
        Set destCell = .Cells(.Rows.Count, "B").End(xlUp)
    End With
   
    Application.ScreenUpdating = False
   
    fileName = Dir(matchFiles)
    While fileName <> vbNullString
        Set fromWorkbook = Workbooks.Open(folder & fileName, ReadOnly:=True)
        With fromWorkbook.Worksheets(1)
            'Filter column B between start date and end date
           
            .Range("B8").CurrentRegion.AutoFilter Field:=1, Criteria1:=">=" & CLng(startDate), Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
           
            If destCell.Row = 1 Then
                'Copy header row and data rows
                .Range("B8").CurrentRegion.Copy destCell
            Else
                'Copy only data rows
                .Range("B8").CurrentRegion.Offset(1).Copy destCell
            End If
        End With
        fromWorkbook.Close False
       
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
       
        DoEvents
        fileName = Dir
    Wend
   
    Application.ScreenUpdating = True
   
    MsgBox "Finished"
   
End Sub

Answer 1

Untested:

Public Sub Copy_AutoFiltered_Rows_From_Workbooks()
    
    Const START_FOLDER As String = "C:\Users\Tim\Desktop\My Files\"
    
    Dim destCell As Range, fromWorkbook As Workbook
    Dim startDate As Date, endDate As Date, colFiles As Collection, f
    
    With ThisWorkbook.ActiveSheet
        If Not IsDate(.Range("A1").Value) Or IsEmpty(.Range("A1").Value) Or _
           Not IsDate(.Range("A2").Value) Or IsEmpty(.Range("A2").Value) Then
            MsgBox "Cells A1 and A2 must contain a date"
            Exit Sub
        End If
        startDate = .Range("A1").Value
        endDate = .Range("A2").Value
        If startDate > endDate Then
            MsgBox "Start date in A1 must be earlier than end date in A2"
            Exit Sub
        End If
        Set destCell = .Cells(.Rows.Count, "B").End(xlUp)
    End With
    Application.ScreenUpdating = False
    
    Set colFiles = GetMatches(START_FOLDER, "*.xls*") '<< ###fixed
    For Each f In colFiles
        Set fromWorkbook = Workbooks.Open(f, ReadOnly:=True)
        With fromWorkbook.Worksheets(1)
            .Range("B8").CurrentRegion.AutoFilter _
                 Field:=1, Criteria1:=">=" & CLng(startDate), _
                 Operator:=xlAnd, Criteria2:="<=" & CLng(endDate)
                 
            .Range("B8").CurrentRegion.Offset(IIf(destCell.Row = 1, 0, 1)).Copy destCell
        End With
        fromWorkbook.Close False
       
        With destCell.Worksheet
            Set destCell = .Cells(.Rows.Count, "B").End(xlUp).Offset(1)
        End With
    Next f
    
    MsgBox "Finished"
End Sub

'Return a collection of file paths given a starting folder and a file pattern
'  e.g. "*.txt"
'Pass False for last parameter if don't want to check subfolders
Function GetMatches(startFolder As String, filePattern As String, _
                    Optional subFolders As Boolean = True) As Collection

    Dim fso, fldr, f, subFldr, fpath
    Dim colFiles As New Collection
    Dim colSub As New Collection
    
    Set fso = CreateObject("scripting.filesystemobject")
    colSub.Add startFolder
    
    Do While colSub.Count > 0
        Set fldr = fso.getfolder(colSub(1))
        colSub.Remove 1
        If subFolders Then
            For Each subFldr In fldr.subFolders
                colSub.Add subFldr.Path
            Next subFldr
        End If
        
        fpath = fldr.Path
        If Right(fpath, 1) <> "\" Then fpath = fpath & "\"
        f = Dir(fpath & filePattern) 'Dir is faster...
        Do While Len(f) > 0
            colFiles.Add fpath & f
            f = Dir()
        Loop
    Loop
    Set GetMatches = colFiles
End Function