VBA实现多工作簿与主工作簿的数据合并方案优化

修改思路 #

针对现有宏仅支持单个手动重命名工作簿的局限，修改核心是自动遍历指定文件夹内所有Excel文件，复用原有数据匹配逻辑完成批量整合，具体调整包括：

• 新增可视化文件夹选择功能，无需手动重命名文件
• 自动后台打开/关闭目标工作簿，全程无需人工干预
• 动态获取数据行范围，替代原固定行号的硬编码逻辑

修改后的完整代码 #

Sub CombineExcel_Batch()
    Dim MASTERwb As Workbook
    Dim MASTERws As Worksheet
    Dim NEWwb As Workbook
    Dim NEWws As Worksheet
    
    Dim MASTERrow As Long
    Dim NEWrow As Long
    Dim lastMasterRow As Long
    Dim lastNewRow As Long
    
    Dim MASTERTrow As Range
    Dim NEWTrow As Range
    
    Dim dtoday As Date
    dtoday = Date
    
    Dim alphaIDColumn As String
    Dim DateColumn As String
    Dim PolicyNoColumn As String
    
    ' 定义列对应关系
    alphaIDColumn = "B"
    DateColumn = "A"
    PolicyNoColumn = "C"
    
    ' 设置主工作簿（假设宏存储在主工作簿中，用ThisWorkbook更稳妥）
    Set MASTERwb = ThisWorkbook
    Set MASTERws = MASTERwb.Worksheets("Sheet1")
    lastMasterRow = MASTERws.Cells(MASTERws.Rows.Count, alphaIDColumn).End(xlUp).Row
    
    ' 让用户选择要处理的个人工作簿所在文件夹
    Dim folderPath As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择存储个人工作簿的文件夹"
        If .Show = -1 Then
            folderPath = .SelectedItems(1) & "\"
        Else
            MsgBox "未选择文件夹，宏终止执行"
            Exit Sub
        End If
    End With
    
    ' 遍历文件夹内的所有Excel文件
    Dim fileName As String
    fileName = Dir(folderPath & "*.xlsx") ' 先处理xlsx格式，如需xls可添加对应遍历逻辑
    
    Do While fileName <> ""
        ' 跳过主工作簿本身
        If folderPath & fileName <> MASTERwb.FullName Then
            ' 后台打开个人工作簿，关闭屏幕刷新提升效率
            Application.ScreenUpdating = False
            Set NEWwb = Workbooks.Open(folderPath & fileName, ReadOnly:=True)
            Set NEWws = NEWwb.Worksheets("Sheet1")
            lastNewRow = NEWws.Cells(NEWws.Rows.Count, DateColumn).End(xlUp).Row
            
            ' 执行数据匹配与复制逻辑
            For NEWrow = 2 To lastNewRow
                If IsDate(NEWws.Cells(NEWrow, DateColumn).Value) Then ' 先判断是否为有效日期，避免报错
                    If CDate(NEWws.Cells(NEWrow, DateColumn).Value) = CDate(dtoday) Then
                        For MASTERrow = 2 To lastMasterRow
                            If MASTERws.Cells(MASTERrow, alphaIDColumn).Value = NEWws.Cells(NEWrow, alphaIDColumn).Value And _
                               MASTERws.Cells(MASTERrow, PolicyNoColumn).Value = NEWws.Cells(NEWrow, PolicyNoColumn).Value Then
                                Set MASTERTrow = MASTERws.Rows(MASTERrow)
                                Set NEWTrow = NEWws.Rows(NEWrow)
                                
                                MASTERTrow.Copy
                                NEWTrow.PasteSpecial xlPasteAll
                                Application.CutCopyMode = False
                                Exit For ' 找到匹配项后退出循环，减少无效遍历
                            End If
                        Next MASTERrow
                    End If
                End If
            Next NEWrow
            
            ' 关闭个人工作簿，不保存修改
            NEWwb.Close SaveChanges:=False
            Application.ScreenUpdating = True
        End If
        
        ' 获取下一个待处理文件
        fileName = Dir
    Loop
    
    MsgBox "批量数据整合完成！"
End Sub

关键修改说明 #

1. 文件夹选择：通过FileDialog实现可视化文件夹选择，无需固定路径或手动重命名
2. 动态行号：用Cells(Rows.Count, 列).End(xlUp).Row获取实际数据最后一行，适配不同数据量的工作簿
3. 批量遍历：使用Dir函数循环处理文件夹内所有Excel文件，自动跳过主工作簿避免重复处理
4. 效率优化：添加Exit For减少无效循环，后台打开工作簿关闭屏幕刷新提升运行速度
5. 错误防护：增加IsDate判断，避免无效日期格式导致的运行错误

使用注意事项 #

• 确保主工作簿的目标工作表名称为"Sheet1"，若不同需修改代码中MASTERws的工作表名称
• 所有个人工作簿的数据表需统一为"Sheet1"，否则需调整NEWws的工作表名称
• 运行宏前请备份所有工作簿，避免意外数据修改

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