根据文件名将多个 Excel 工作簿合并为单个 Excel 工作簿 - VBA

使用字典和集合。首先扫描目录以编译主工作簿列表，然后使用集合打开和复制工作表。

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

将您当前的 sub 转换为接受字母模式，并通过一个主要的来调用它来提供所有想要的字母

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

这是你原来的 @H_993_33@merge() 子，我适应了这个任务：

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

如你所见，我还采用了一些风格上的变化，其中之一是我的个人代码缩进模式，你可能觉得它有用与否

将多个工作簿中的工作表合并到主工作簿

• 代码应位于不在源文件夹路径 (FolderPath) 内的文件的模块中，或者至少位于名称没有前缀的文件中。
• 未经测试。

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

创建一个名为 class 的 WorkbookMerger 并将以下代码添加到其中

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

现在在任何 @H_993_33@module 中添加以下代码

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. 该类采用 basepath 并基于常量 SaveInFolder 在 basepath 下创建一个子文件夹，其中将存储所有处理过的文件。
2. 读取 basepath 中的所有文件并检索基于 Delim。
3. 循环遍历每个键（唯一模式），创建文件基础模式 并再次处理所有文件名以检查是否有任何文件名 匹配此模式。
4. 如果匹配，它的工作表将被复制到这个新文件中，并在 最后这个文件将保存在带有图案名称的子文件夹中。

我尝试了 20 个不同模式的不同文件，它按预期工作。 如果行得通，现在告诉我。