VBA：递归代码 - 从多个子文件夹中提取数据

Question

为了简短起见，下面的代码从文件夹中的多个工作簿中提取数据。我的问题是，其他文件位于同一驱动器但位于子文件夹中。

如何使用下面的代码提取它？ =(

例如

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)

所有工作簿都位于 Drive Z>My items>Reports 文件夹中。

如有任何帮助，我们将不胜感激。提前致谢。

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

未测试：

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

VBA：递归代码 - 从多个子文件夹中提取数据

VBA: Recursive code - Extract Data from multiple sub folders

excel

vba