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

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:UsersTimDesktopMy Files*.xlsm"
'matchFiles = "D:TempExcelWorkbooksDraft*.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:UsersTimDesktopMy 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