여러 개의 디렉터리에서 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