根據文件名將多個 Excel 工作簿組合成單獨的 Excel 工作簿 - VBA

Question

我有多個工作簿保存在 C:\Temp 中。

他們看起來像：

• 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
• 等等

我想將這些文件合並到主工作簿中，因此在上面的示例中，我將擁有包含來自 AAAA_1、AAAA_2 和 AAAA_3 的數據的主文件 AAAA，包含來自 BBBB_1 和 BBBB_2 的數據的主文件 BBBB 等。

下面是我目前的 VBA。 我能夠搜索前綴“AAAA”並創建一個新的主文件，其中包含來自 AAAA_1、AAAA_2 和 AAAA_3 的所有選項卡，但是然后我如何（自動）重新開始並為存在的所有其他前綴創建主文件C:\溫度？ 感謝 VBA 菜鳥！

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

使用字典和 collections。 掃描目錄先編譯主工作簿列表，然后使用 collections 打開和復制工作表。

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

將您當前的子轉換為接受字母模式，並由一個主要的調用它來提供所有想要的字母

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

這是你原來的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

如您所見，我還采用了一些樣式更改，其中之一是我的個人代碼縮進模式，您可能會發現它有用或無用

Answer 3

將多個工作簿中的工作表合並到主工作簿

• 代碼應位於不在源文件夾路徑 ( 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

Answer 4

創建一個名為WorkbookMerger的class並將以下代碼添加到其中

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

現在在任何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. class 采用基本路徑，並基於常量SaveInFolder在基本路徑下創建一個子文件夾，所有處理過的文件都將存儲在其中。
2. 讀取基本路徑中的所有文件並根據Delim檢索唯一模式。
3. 循環遍歷每個鍵（唯一模式），創建文件基礎 don 模式並再次處理所有文件名以檢查是否有任何文件名與此模式匹配。
4. 如果匹配，它的工作表將被復制到這個新文件中，最后這個文件將保存在帶有模式名稱的子文件夾中。

我嘗試了 20 個具有不同模式的不同文件，它按預期工作。 現在讓我看看它是否有效。