VBA – 合并范围从一个文件夹和SUBFOLDER中的所有工作簿
目前，当我的文件只在名为“E：\ Dian \ Test”的主文件夹中时，我的代码运行良好。 （仅读取主文件夹（MyPath）中复制的文件，而不读取子文件夹中的文件）
我的问题是如何改变/添加到我现有的代码，包括一个循环，以包括通过子文件夹，在E：\ Dian \ Test文件夹中search.xlsx文件开始名称“out_ *”
请记住，我的编程技能不是很好。
谢谢 ：）
Private Sub CommandButton1_Click() Dim MyPath As String, FilesInPath As String Dim myCountFiles As Long Dim myFiles() As String Dim SourceRcount As Long, Fnum As Long Dim mybook As Workbook, BaseWks As Worksheet Dim sourceRange As Range, destrange As Range Dim rnum As Long, CalcMode As Long Dim FirstCell As String Dim emptyColumn As Long Dim NextRow As Range ' Change this to the path\folder location of your files.' 'How do you include a loop to include searching through SubFolders, within the E:\Dian\Test folder, for xlsx files starting with the name "out_*"??????????????????????????????????????' MyPath = "E:\Dian\Test\" ' Add a slash at the end of the path if needed. If Right(MyPath, 1) <> "\" Then MyPath = MyPath & "\" End If ' If there are no Excel files in the folder, exit. FilesInPath = Dir(MyPath & "*.xl*") If FilesInPath = "" Then MsgBox "No files found" Exit Sub End If ' Fill the myFiles array with the list of Excel files ' in the search folder. Fnum = 0 Do While FilesInPath <> "" If FilesInPath <> ActiveWorkbook.Name Then Fnum = Fnum + 1 ReDim Preserve myFiles(1 To Fnum) myFiles(Fnum) = FilesInPath End If FilesInPath = Dir() Loop ' Set various application properties. With Application CalcMode = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With ' Add a new workbook/existing sheet. If Workbooks.Count > 1 Then Call MsgBox("Please close all other workbooks", vbOKOnly) Exit Sub End If Set BaseWks = ActiveWorkbook.Worksheets("1_Input_Data") With BaseWks rnum = .Cells(Rows.Count, "A").End(xlUp).Row + 1 End With ' Loop through all files in the myFiles array. If Fnum > 0 Then For Fnum = LBound(myFiles) To UBound(myFiles) Set mybook = Nothing On Error Resume Next Set mybook = Workbooks.Open(MyPath & myFiles(Fnum)) On Error GoTo 0 If Not mybook Is Nothing Then On Error Resume Next ' Change this range to fit your own needs. With mybook.Worksheets("Summary") FirstCell = "A4" Set sourceRange = .Range(FirstCell & ":" & RDB_Last(3, .Cells)) ' Test if the row of the last cell is equal to or greater than the row of the first cell. If RDB_Last(1, .Cells) < .Range(FirstCell).Row Then Set sourceRange = Nothing End If End With If Err.Number > 0 Then Err.Clear Set sourceRange = Nothing Else ' If source range uses all columns then ' skip this file. If sourceRange.Columns.Count >= BaseWks.Columns.Count Then Set sourceRange = Nothing End If End If On Error GoTo 0 If Not sourceRange Is Nothing Then SourceRcount = sourceRange.Rows.Count If rnum + SourceRcount >= BaseWks.Rows.Count Then MsgBox "There are not enough rows in the target worksheet." BaseWks.Columns.AutoFit mybook.Close SaveChanges:=False GoTo ExitTheSub Else ' Copy the file name in column A. With sourceRange BaseWks.UsedRange(rnum, "A"). _ Resize(.Rows.Count).Value = Mid(myFiles(Fnum), WorksheetFunction.Find("out_", myFiles(Fnum)) + 4, WorksheetFunction.Find(".xlsx", myFiles(Fnum)) - WorksheetFunction.Find("out_", myFiles(Fnum)) - 4) End With ' Set the destination range. Set destrange = BaseWks.Range("B" & rnum) ' Copy the values from the source range ' to the destination range. With sourceRange Set destrange = destrange. _ Resize(.Rows.Count, .Columns.Count) End With destrange.Value = sourceRange.Value rnum = rnum + SourceRcount End If End If mybook.Close SaveChanges:=False End If Next Fnum BaseWks.Columns.AutoFit End If ExitTheSub: ' Restore the application properties. With Application .ScreenUpdating = True .EnableEvents = True .Calculation = CalcMode End With End Sub 对于这类问题，我使用了Command Shell。 你可以使用PowerShell，但我还没有开发的代码。
这是一个简短的例程，它将所有名称中包含特定模式的文件放入数组vFileList 。 然后你可以迭代该数组。
请注意，shell dir命令使用\S和\B开关。
\ S意味着阅读这个文件夹中的项目，所有的子文件夹\ B删除所有无关的信息，只留下完整的文件path
在你的情况下，你可能会设置
MyPath = "E:\Dian\Test\out_*.xlsx" Option Explicit 'set reference to Windows Script Host Object Model Sub GetFiles() Const myPath As String = "D:\Users\Ron\b*.xlsx" Dim WSH As WshShell Dim vFileList As Variant Set WSH = New WshShell vFileList = Split(WSH.Exec("CMD /c dir """ & myPath & """/B /S").StdOut.ReadAll, vbLf) End Sub