根据文件名将多个 Excel 工作簿组合成单独的 Excel 工作簿 - VBA

Question

I have multiple workbooks saved in C:\Temp.

They look like:

• AAAA_1.xlsx
• AAAA_2.xlsx
• AAAA_3.xlsx
• BBBB_1.xksx
• BBBB_2.xksx
• CCCC_1.xlsx
• CCCC_2.xlsx
• CCCC_3.xlsx
• CCCC_4.xlsx
• etc.

I want to combine these files into master workbooks, so in the above example, I would have master file AAAA with data from AAAA_1, AAAA_2 and AAAA_3, a master file BBBB with data from BBBB_1 and BBBB_2, etc.

Below is my current VBA. I am able to search for prefix "AAAA" and that creates a new master file with all tabs from AAAA_1, AAAA_2 and AAAA_3, but then how to I start over (automatically) and create master files for all of the other prefixes that exist in C:\Temp? Thanks from a VBA rookie!

Sub Merge()
Path = "C:\Temp\"
Filename = Dir(Path & "AAAA" & "*.xlsx")
Do While Filename <> ""
Workbooks.Open Filename:=Path & Filename, ReadOnly:=True
 For Each Sheet In ActiveWorkbook.Sheets
   Sheet.Copy After:=ThisWorkbook.Sheets(1)
Next Sheet
 Application.DisplayAlerts = False
 Workbooks(Filename).Close
 Filename = Dir()
'Save workbook
Loop
 Application.DisplayAlerts = True
 
ActiveWorkbook.SaveAs Filename:="C:\Temp\File_" & Range("A1") & ".xlsx", FileFormat:= _
xlOpenXMLWorkbook, CreateBackup:=False
End Sub

Answer 1

Using a dictionary and collections. Scans the directory to compile a list of master workbooks first and then uses the collections to open and copy the sheets.

Option Explicit

Sub consolidate()

    Const FOLDER = "C:\Temp\"

    Const SEP_COUNT = 0 'set to 0 to use fixed width
    Const SEP = "_"
    Const FIXED_WIDTH = 3 '
   
    Dim wb As Workbook, wbMaster As Workbook, ws As Worksheet
    Dim dict As Object, k, c As Collection, ar, f
    Dim m As Integer, n As Integer
    Dim sFile As String, s As String
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' build collections
    sFile = Dir(FOLDER & "*.xlsx")
    Do While Len(sFile) > 0
        k = ""
       
        ' avoid masters
        If sFile Like "Master*" Then
            ' do nothing
        ElseIf SEP_COUNT > 0 Then
            If InStr(sFile, SEP) > 0 Then
                ' example INV_1104092_05_31_2021_000.xlsx
                ar = Split(sFile, SEP, SEP_COUNT + 1)
                If UBound(ar) >= SEP_COUNT Then
                     k = ar(0)
                     For n = 1 To SEP_COUNT - 1
                         k = k & "_" & ar(n)
                     Next
                End If
             End If
        ElseIf FIXED_WIDTH > 0 Then
            k = Left(sFile, FIXED_WIDTH)
        End If

        If Len(k) > 0 Then
            If Not dict.exists(k) Then
                dict.Add k, New Collection
            End If
            Set c = dict.Item(k)
            c.Add Trim(sFile), CStr(c.Count + 1)
        End If

        sFile = Dir
    Loop

    ' copy sheets
    Application.ScreenUpdating = False
    For Each k In dict
        ' create new master
        Set wbMaster = Workbooks.Add
        m = wbMaster.Sheets.Count
        n = m
        For Each f In dict(k) ' files in collection
            Set wb = Workbooks.Open(FOLDER & f, 1, 1)
            s = Replace(Mid(f, Len(k) + 1), ".xlsx", "")
            ' remove _ from front
            If SEP_COUNT > 0 And Left(s, 1) = "_" Then s = Mid(s, 2)
            For Each ws In wb.Sheets
                ws.Copy After:=wbMaster.Sheets(n)
                n = n + 1
                wbMaster.Sheets(n).Name = s & "_" & ws.Name
            Next
            wb.Close False
        Next

        ' delete initial sheets
        Application.DisplayAlerts = False
        For n = m To 1 Step -1
            wbMaster.Sheets(n).Delete
        Next
        Application.DisplayAlerts = True
     
        ' save master
        wbMaster.SaveAs FOLDER & "Master_" & k & ".xlsx", _
               FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        wbMaster.Close False
    Next
    ' end
    Application.ScreenUpdating = True
    MsgBox dict.Count & " master files created", vbInformation

End Sub

Answer 2

Convert your current sub to accept the letter pattern and call it by a main one feeding all wanted letters

Sub Merge()
    Const letters As String = "ABCDEFG" ' collect all wanted initial letters
    
    Dim iLetter As Long
        For iLetter = 1 To Len(letters) ' loop through letters
            MergeLetter String(4,Mid$(letters, iLetter, 1))
        Next
    
End Sub

and here's your original Merge() sub, I adapted for the task:

Sub MergeLetter(letter As String)

    Dim masterWb As Workbook  
        Set masterWb = Workbooks.Add 'open a new "master" workbook

    Dim path As String
        path = "C:\Temp\"
    
        Dim fileName As String
            fileName = Dir(path & letter & "*.xlsx")
        
            Do While fileName <> vbNullString

                With Workbooks.Open(fileName:=path & fileName, ReadOnly:=True)
                    Dim sh As Worksheet
                        For Each sh In .Worksheets
                           sh.Copy After:=masterWb.Sheets(1)
                        Next
                        .Close
                End With

                fileName = Dir()

            Loop
     
            With masterWb
                .SaveAs fileName:=path & letter & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
                .Close False
            End With
End Sub

as you see, I also adopted some stylistic changes, one of them being my personal code indentation pattern, which you may found userful or not

Answer 3

Merge Sheets from Multiple Workbooks to Master Workbooks

• The code should be located in a module of a file that is not inside the source folder path ( FolderPath ) or at least a file whose name has none of the prefixes.
• Not tested.

Option Explicit

Sub mergeSheets()
    
    Const FolderPath As String = "C:\Temp\"
    Const PrefixesList As String = "AAAA,BBBB,CCCC"
    
    Dim Prefixes() As String: Prefixes = Split(PrefixesList, ",")
    
    Dim swb As Workbook
    Dim dwb As Workbook
    Dim sh As Object
    Dim fName As String
    Dim n As Long
    Dim dshCount As Long
        
    Application.ScreenUpdating = False
        
    For n = 0 To UBound(Prefixes)
        fName = Dir(FolderPath & Prefixes(n) & "*.xlsx")
        dshCount = 0
        Do Until Len(fName) = 0
            Set swb = Workbooks.Open(FolderPath & fName, , True)
            For Each sh In swb.Sheets ' charts and what not included
                If dshCount = 0 Then
                    sh.Copy ' creates a new workbook containing one sheet
                    Set dwb = ActiveWorkbook
                Else
                    sh.Copy After:=dwb.Sheets(dshCount)
                End If
                dshCount = dshCount + 1
            Next sh
            swb.Close SaveChanges:=False
            fName = Dir
        Loop
        ' Maybe you wanna rather do '... & Prefixes(n) & ".xlsx",...'
        dwb.SaveAs "C:\Temp\File_" & dwb.WorkSheets(1).Range("A1") & ".xlsx", _
            xlOpenXMLWorkbook, , , , False
        dwb.Close
    Next n

    Application.ScreenUpdating = True

End Sub

Answer 4

Create a class Named WorkbookMerger and add the following code into it

Option Explicit
''Add/check Tools> Reference> Microsoft Scripting Runtime

Private FileSysObject As Scripting.FileSystemObject
Private Fullfolder  As Scripting.Folder
Private SingleFile As Scripting.File
Private dict As Scripting.Dictionary
Private ProccessedFolder As String

Private Const Delim As String = "_"
Private Const SaveInFolder As String = "ProccessedFiles"

Public Function Execute(ByVal BasePath As String) As Boolean
    Set Fullfolder = FileSysObject.GetFolder(BasePath)
     
    ProccessedFolder = FileSysObject.BuildPath(BasePath, SaveInFolder)
    
    Execute = False
    If Not FileSysObject.FolderExists(ProccessedFolder) Then
        FileSysObject.CreateFolder (ProccessedFolder)
    End If
    
    If ReadPatterns Is Nothing Then
        Exit Function
    Else
        ProcessFiles
    End If
    Execute = True
End Function

Private Function ReadPatterns() As Scripting.Dictionary
    For Each SingleFile In Fullfolder.Files
    
        Dim Pattern As String
        Pattern = Split(SingleFile.Name, Delim)(0) 'change delimeter
        
        On Error Resume Next
        If Not dict.Exists(Pattern) Then dict.Add Pattern, CStr(Pattern)

    Next SingleFile
    Set ReadPatterns = dict
End Function

Private Sub ProcessFiles()

    Dim key As Variant
    For Each key In dict
        'loop through all patterns in dict and process each file if it matches

        Dim masterWb As Workbook
        Dim masterwbName As String
        masterwbName = ProccessedFolder & "\" & key & ".xlsx"
        If FileSysObject.FileExists(masterwbName) Then
            Set masterWb = Workbooks.Open(masterwbName)
        Else
            Set masterWb = Workbooks.Add
        End If

        For Each SingleFile In Fullfolder.Files
            With SingleFile
        
                If .Name Like key & "*" Then
            
                    Dim Wsheet As Worksheet
                    Dim wb As Workbook
                    Set wb = Workbooks.Open(Fullfolder.Path & "\" & SingleFile.Name, ReadOnly:=True)
                    For Each Wsheet In wb.Worksheets
                        Wsheet.Copy after:=masterWb.Sheets(1)
                    
                    Next Wsheet
                    wb.Close False
                    'close file without saving any changes
                End If
            End With
                    
        Next SingleFile
        With masterWb
            .SaveAs masterwbName, xlOpenXMLWorkbook
            .Close True
        End With

    Next key
End Sub

Private Sub Class_Initialize()
    Set FileSysObject = New Scripting.FileSystemObject
    Set dict = New Scripting.Dictionary
End Sub

Now in any module add the following code

Public Sub Testing()
    Dim WMerger As WorkbookMerger
    Set WMerger = New WorkbookMerger
    On Error GoTo ErrorExit:
    With Application
        '.Calculation = xlCalculationAutomatic
        .Calculation = xlCalculationManual
        .ScreenUpdating = False
        .EnableCancelKey = xlInterrupt
    End With
    
    If WMerger.Execute("C:\Temp") Then MsgBox "Completed"

ErrorExit:
    
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .StatusBar = False
    End With
End Sub

1. The class takes basepath and based on constant SaveInFolder it creates a sub-folder under basepath where all processed files will be stored.
2. Reads all file in basepath and retrieves unique patterns based on the Delim .
3. Loop through each key(unique pattern), Create file base don pattern and process all filenames again to check if any of the file name matches this pattern.
4. If matches it's worksheets will be copied in this new file and at last this file will be saved in sub folder with Pattern name.

I tried with 20 different files with different patterns and it works as expected. Let me now if it works.