求助：基于订单号合并多文件夹Excel工作簿的VBA宏

我是VBA初学者，缺乏足够VBA知识，现寻求协助开发VBA宏，基于另一Excel文件中的订单号，合并位于不同文件夹中的多个工作簿完成数据迁移工作。

场景说明 #

• Folder 1、Folder 3各包含1个带单工作表的Excel工作簿
• Folder 2包含约300个以订单号命名的数据工作簿（每个工作簿仅含1个工作表）
• Folder 4包含与Folder 2数量一致、文件名对应订单号的工作簿（每个工作簿仅含1个工作表）

需求 #

1. 读取指定订单号列表，为每个订单号创建独立的合并工作簿
2. 每个合并工作簿需包含四类工作表：Folder1的工作表、Folder2对应订单号的工作表、Folder3的工作表、Folder4对应订单号的工作表，按文件夹顺序排列
3. 保留所有原工作表的名称，不修改
4. 合并工作簿以对应订单号命名

本人尝试的代码 #

Sub MergeWorkbooks()

    Dim FolderPath1 As String, FolderPath2 As String, FolderPath3 As String, FolderPath4 As String
    Dim OrderNumbersFilePath As String
    Dim OrderNumbersWorkbook As Workbook
    Dim OrderNumbersSheet As Worksheet
    Dim FinalWorkbook As Workbook
    Dim DataWorkbook As Workbook
    Dim OrderNumber As String
    
    ' Set the folder paths for each folder
    FolderPath1 = "Path\\to\\Folder1\\"
    FolderPath2 = "Path\\to\\Folder2\\"
    FolderPath3 = "Path\\to\\Folder3\\"
    FolderPath4 = "Path\\to\\Folder4\\"
    
    ' Set the file path of the workbook containing order numbers
    OrderNumbersFilePath = "C:\\OrderNumbersWorkbook.xlsx"
    
    ' Open the workbook containing order numbers
    Set OrderNumbersWorkbook = Workbooks.Open(OrderNumbersFilePath)
    Set OrderNumbersSheet = OrderNumbersWorkbook.Worksheets(1)
    
    ' Create a new workbook for the final result
    Set FinalWorkbook = Workbooks.Add
    
    ' Loop through each order number in the list
    For i = 1 To OrderNumbersSheet.Cells(Rows.Count, 1).End(xlUp).Row
        OrderNumber = OrderNumbersSheet.Cells(i, 1).Value
        
        ' Open the corresponding data workbook from Folder2
        Set DataWorkbook = Workbooks.Open(FolderPath2 & "\\" & OrderNumber & ".xlsx")
        
        ' Copy the data from the data workbook to the final workbook
        DataWorkbook.Worksheets(1).Copy After:=FinalWorkbook.Sheets(FinalWorkbook.Sheets.Count)
        FinalWorkbook.Sheets(FinalWorkbook.Sheets.Count).Name = OrderNumber
        
        ' Close the data workbook without saving changes
        DataWorkbook.Close SaveChanges:=False
        
        ' Open the corresponding workbook from Folder4
        Set DataWorkbook = Workbooks.Open(FolderPath4 & "\\" & OrderNumber & ".xlsx")
        
        ' Copy the data from the workbook to the final workbook
        DataWorkbook.Worksheets(1).UsedRange.Copy Destination:=FinalWorkbook.Sheets(OrderNumber).Cells(Rows.Count, 1).End(xlUp).Offset(1)
        
        ' Close the workbook without saving changes
        DataWorkbook.Close SaveChanges:=False
    Next i
    
    ' Save and close the final workbook
    FinalWorkbook.SaveAs "C:\\to\\Output_Workbook.xlsx"
    FinalWorkbook.Close
    
    ' Close the order numbers workbook
    OrderNumbersWorkbook.Close
End Sub

修正后的代码及说明 #

代码实现 #

Sub MergeWorkbooksByOrderNumber()
    ' 声明变量
    Dim FolderPath1 As String, FolderPath2 As String, FolderPath3 As String, FolderPath4 As String
    Dim OrderNumbersFilePath As String
    Dim OrderNumbersWB As Workbook, OrderNumbersWS As Worksheet
    Dim FinalWB As Workbook
    Dim SourceWB As Workbook
    Dim OrderNumber As String
    Dim i As Long
    Dim OutputFolder As String
    
    ' --------------------------
    ' 配置路径（请修改为实际路径）
    ' --------------------------
    FolderPath1 = "C:\YourPath\Folder1\"
    FolderPath2 = "C:\YourPath\Folder2\"
    FolderPath3 = "C:\YourPath\Folder3\"
    FolderPath4 = "C:\YourPath\Folder4\"
    OrderNumbersFilePath = "C:\YourPath\OrderNumbersWorkbook.xlsx"
    OutputFolder = "C:\YourPath\Output\" ' 合并后文件的保存目录
    
    ' 创建输出目录（如果不存在）
    If Dir(OutputFolder, vbDirectory) = "" Then
        MkDir OutputFolder
    End If
    
    ' 打开订单号列表工作簿
    Set OrderNumbersWB = Workbooks.Open(OrderNumbersFilePath)
    Set OrderNumbersWS = OrderNumbersWB.Worksheets(1)
    
    ' 关闭屏幕刷新，提升运行速度
    Application.ScreenUpdating = False
    
    ' 遍历订单号列表
    For i = 1 To OrderNumbersWS.Cells(Rows.Count, 1).End(xlUp).Row
        OrderNumber = Trim(OrderNumbersWS.Cells(i, 1).Value)
        If OrderNumber <> "" Then ' 跳过空行
            
            ' 1. 创建新的合并工作簿（仅1个空白工作表）
            Set FinalWB = Workbooks.Add(xlWBATWorksheet)
            
            ' 2. 复制Folder1的工作表到合并工作簿
            Set SourceWB = Workbooks.Open(FolderPath1 & Dir(FolderPath1 & "*.xlsx"))
            SourceWB.Worksheets(1).Copy Before:=FinalWB.Sheets(1)
            SourceWB.Close SaveChanges:=False
            
            ' 3. 复制Folder2对应订单号的工作表
            If Dir(FolderPath2 & OrderNumber & ".xlsx") <> "" Then
                Set SourceWB = Workbooks.Open(FolderPath2 & OrderNumber & ".xlsx")
                SourceWB.Worksheets(1).Copy After:=FinalWB.Sheets(FinalWB.Sheets.Count)
                SourceWB.Close SaveChanges:=False
            Else
                MsgBox "Folder2中未找到订单号：" & OrderNumber, vbExclamation
            End If
            
            ' 4. 复制Folder3的工作表
            Set SourceWB = Workbooks.Open(FolderPath3 & Dir(FolderPath3 & "*.xlsx"))
            SourceWB.Worksheets(1).Copy After:=FinalWB.Sheets(FinalWB.Sheets.Count)
            SourceWB.Close SaveChanges:=False
            
            ' 5. 复制Folder4对应订单号的工作表
            If Dir(FolderPath4 & OrderNumber & ".xlsx") <> "" Then
                Set SourceWB = Workbooks.Open(FolderPath4 & OrderNumber & ".xlsx")
                SourceWB.Worksheets(1).Copy After:=FinalWB.Sheets(FinalWB.Sheets.Count)
                SourceWB.Close SaveChanges:=False
            Else
                MsgBox "Folder4中未找到订单号：" & OrderNumber, vbExclamation
            End If
            
            ' 删除默认的空白工作表
            Application.DisplayAlerts = False
            FinalWB.Sheets("Sheet1").Delete
            Application.DisplayAlerts = True
            
            ' 保存合并后的工作簿（以订单号命名）
            FinalWB.SaveAs Filename:=OutputFolder & OrderNumber & ".xlsx", FileFormat:=xlOpenXMLWorkbook
            FinalWB.Close SaveChanges:=False
        End If
    Next i
    
    ' 恢复屏幕刷新
    Application.ScreenUpdating = True
    
    ' 关闭订单号列表工作簿
    OrderNumbersWB.Close SaveChanges:=False
    
    MsgBox "合并完成！", vbInformation
End Sub

关键修改点说明 #

1. 路径配置优化：集中配置所有路径，新增输出目录自动创建逻辑，避免手动建文件夹
2. 严格按顺序排列工作表：完全遵循Folder1→Folder2→Folder3→Folder4的要求排列
3. 保留原工作表名称：不修改任何源工作表名称，完全继承原文件设置
4. 错误预防：跳过订单号空行，检查目标文件是否存在，避免运行报错
5. 性能提升：关闭屏幕刷新和警告提示，大幅提升批量处理300个文件的速度
6. 符合命名需求：每个订单号生成独立工作簿，直接以订单号命名

使用注意事项 #

• 请将代码中的路径替换为你的实际文件夹路径
• Folder1和Folder3中确保只有1个Excel文件，否则Dir函数会取目录中第一个Excel文件
• 若需要将所有订单号的工作表合并到同一个工作簿，可修改代码逻辑，将每个订单号的四类工作表添加到同一个FinalWB中，并按订单号分组

内容的提问来源于stack exchange，提问作者Deepak