VBA: Get Data from multiple folder and sub folders

[Xlacs]

Hello Good People,


To make it short so below code extract data from a multiple workbooks in a folder.
My question is, other files are located in the same drive but in a sub folder.

How to extract it ith 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.

Any help would be greatly appreciated. Thanks in Advance.

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

 

[JEC]

Here is another option, which is doing the same as my previous code. This is a more direct approach.

Sub jec()
Dim a
a = Split(CreateObject("wscript.shell").Exec("cmd /c Dir ""C:\Users\xxx\Downloads\*.xlsm""/b/o:d/s").StdOut.ReadAll, vbCrLf)
If IsArray(a) Then Cells(2, 10).Resize(UBound(a)) = Application.Transpose(a)
End Sub

 

[Xlacs]

Sorry for the confusion but yeah, I did changed it to my path. However the line getFile "C:\Users\xxx\Downloads\" is giving me an invalid argument

 

[JEC]

Show me the complete code.
Open a new module and paste the code. Then change the path and run it. That has to work