VBA遍历多个目录并合并总结工作簿中的数据

Question

我有一个运行在指定目录上的宏，创建一个新的汇总工作簿，然后将选定的数据从存在的所有Excel文件（在定义的目录中）复制到摘要工作簿，然后将摘要工作簿保存到新定义的位置并关闭。每次我有多个文件夹进行数据合并时，我有义务更改目录名称，有时超过30个目录。

我想让这个宏自动循环包含在一个根目录内的几个目录，并执行上面详述的相同操作。怎么可能？我使用了“脚本文件夹”方法，但是当我运行代码时它返回了错误......从未得到它的工作！

其次，我希望这个宏保存汇总工作簿及其文件夹名称，从中合并数据的目录。

我的代码是在这里，请看看，并提出了我一个解决方案：

Sub MergeSitu() 
Dim MyPath As String, FilesInPath As String 
Dim MyFiles() As String 
Dim SourceCcount As Long, FNum As Long 
Dim mybook As Workbook, BaseWks As Worksheet 
Dim sourceRange1 As Range, destrange1 As Range 
Dim sourceRange2 As Range, destrange2 As Range 
Dim sourceRange3 As Range, destrange3 As Range 
Dim Rnum As Long, CalcMode As Long 
Dim Cnum As Long 
Dim listwb As Workbook 
Dim mMonth As Range 

' Change this to the path\folder location of the files. 
MyPath = "D:\data\19h\13 feb\" 

' Add a slash at the end of 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 & "*.xlsx*") 
If FilesInPath = "" Then 
    MsgBox "No files found" 
    Exit Sub 
End If 
' Fill in the myFiles array with the list of Excel files in 
' the search folder. 
FNum = 0 
Do While FilesInPath <> "" 
    FNum = FNum + 1 
    ReDim Preserve MyFiles(1 To FNum) 
    MyFiles(FNum) = FilesInPath 
    FilesInPath = Dir() 
Loop 

' Change the application properties. 
With Application 
    CalcMode = .Calculation 
    .Calculation = xlCalculationManual 
    .ScreenUpdating = False 
    .EnableEvents = False 
End With 

' Add a new workbook with one sheet. 
With Application 

'--> Set contractor list file 
Set listwb = .Workbooks.Open _ 
("D:\data\DataAssemble.xlsx") 
End With 
Set BaseWks = listwb.Sheets(1) 
Cnum = 1 
ActiveWorkbook.Sheets(1).Select 
Range("P1").Select 
ActiveCell.FormulaR1C1 = "Prod" 

For Each mMonth In Sheets(1).Range("P1") 
ActiveWorkbook.Sheets.Add after:=Worksheets(Worksheets.count) 
ActiveSheet.Name = mMonth 
Next 
Set BaseWks = listwb.Sheets(7) 
Cnum = 1 

' Loop through all of the 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 
      Set sourceRange1 = mybook.Worksheets(1).Range("A1:B1420") 

      If Err.Number > 0 Then 
       Err.Clear 
       Set sourceRange1 = Nothing 

      Else 
       ' If the source range uses all of the rows 
       ' then skip this file. 
       If sourceRange1.Rows.count >= BaseWks.Rows.count Then 
        Set sourceRange1 = Nothing 

       End If 
      End If 

      On Error GoTo 0 

      If Not sourceRange1 Is Nothing Then 

       SourceCcount = sourceRange1.Columns.count 

       If Cnum + SourceCcount >= BaseWks.Columns.count Then 
        MsgBox "There are not enough columns in the sheet." 
        BaseWks.Columns.AutoFit 
        mybook.Close savechanges:=False 
        GoTo ExitTheSub 
       Else 

        ' Copy the file name in the first row. 
        With sourceRange1 
         BaseWks.Cells(1, Cnum). _ 
           Resize(, .Columns.count).Value = MyFiles(FNum) 
        End With 


        ' Set the destination range. 
        Set destrange1 = BaseWks.Cells(1, Cnum) 
        ' Copy the values from the source range 
        ' to the destination range. 
        With sourceRange1 
         Set destrange1 = destrange1. _ 
             Resize(.Rows.count, .Columns.count) 
        End With 

        destrange1.Value = sourceRange1.Value 

        Cnum = Cnum + SourceCcount 
       End If 
      End If 
     mybook.Close savechanges:=False 
     End If 
BaseWks.Columns.AutoFit 
    Next FNum 
End If 
listwb.Activate 
ActiveWorkbook.SaveAs Filename:="D:\data\Merged\19h\Data_ " & (FolderName) & ".xlsx", 
Password:="", _ 
WriteResPassword:="", ReadOnlyRecommended:=False, CreateBackup:=False 
ActiveWorkbook.Close 

ExitTheSub: 
'Restore ScreenUpdating, Calculation and EnableEvents 
With Application 
    .ScreenUpdating = True 
    .EnableEvents = True 
    .Calculation = CalcMode 
End With 
End Sub 

谢谢！ Sanjeev

Answer 1

我获得从该代码：http://vba-tutorial.com/merging-multiple-workbooks-togeather-by-searching-directories-and-sub-folders/

步骤1 - 递归函数

Sub RecursiveFileSearch(ByVal targetFolder As String, ByRef objRegExp As Object, _ 
       ByRef matchedFiles As Collection, ByRef objFSO As Object) 

    Dim objFolder As Object 
    Dim objFile As Object 
    Dim objSubFolders As Object 

    'Get the folder object associated with the target directory 
    Set objFolder = objFSO.GetFolder(targetFolder) 

    'Loop through the files current folder 
    For Each objFile In objFolder.Files 
     If objRegExp.test(objFile) Then 
      matchedFiles.Add (objFile) 
     End If 
    Next 

    'Loop through the each of the sub folders recursively 
    Set objSubFolders = objFolder.Subfolders 
    For Each objSubfolder In objSubFolders 
     RecursiveFileSearch objSubfolder, objRegExp, matchedFiles, objFSO 
    Next 

    'Garbage Collection 
    Set objFolder = Nothing 
    Set objFile = Nothing 
    Set objSubFolders = Nothing 

End Sub 

第2步 - 递归控制器

Function FindPatternMatchedFiles(sPath As String) As Collection 

    Dim objFSO As Object 
    Set objFSO = CreateObject("Scripting.FileSystemObject") 

    Dim objRegExp As Object 
    Set objRegExp = CreateObject("VBScript.RegExp") 
    objRegExp.Pattern = ".*\.(xls|xlsx)" 
    objRegExp.IgnoreCase = True 

    Dim colFiles As Collection 
    Set colFiles = New Collection 

    RecursiveFileSearch sPath, objRegExp, colFiles, objFSO 

    'Garbage Collection 
    Set objFSO = Nothing 
    Set objRegExp = Nothing 

    Set FindPatternMatchedFiles = colFiles 

End Function 

步骤3 - 合并在一起每个配套练习册

Sub MergeWorkbooks(sPath As String, sWbName As String) 

    Dim colFiles As Collection 
    Set colFiles = FindPatternMatchedFiles(sPath) 

    Dim appExcel As New Excel.Application 
    appExcel.Visible = False 

    Dim wbDest As Excel.Workbook 
    Set wbDest = appExcel.Workbooks.Add() 

    Dim wbToAdd As Excel.Workbook 
    Dim sheet As Worksheet 

    For Each file In colFiles 

     Set wbToAdd = appExcel.Workbooks.Open(file) 

     For Each sheet In wbToAdd.Sheets 
      sheet.Copy Before:=wbDest.Sheets(wbDest.Sheets.Count) 
     Next sheet 

     wbToAdd.Close SaveChanges:=False 

    Next 

    wbDest.Close True, sPath + "\" + sWbName 
    Set wbDest = Nothing 
    Set appExcel = Nothing 

End Sub 

第4步 - 呼叫合并工作簿子程序

Sub Main() 

    MergeWorkbooks "C:\Path\To\Folder", "Awesomeness.xlsx" 

End Sub