多Excel工作簿合并：保留同名工作表并追加数据

修改后的VBA脚本 #

Sub MergeSpecifiedSheets()
    Dim fnameList, fnameCurFile As Variant
    Dim countFiles As Integer
    Dim wbkCurBook As Workbook
    Dim wbkSrcBook As Object ' 配合GetObject后台读取源工作簿
    Dim srcSheet As Object
    Dim targetSheet As Worksheet
    Dim srcLastRow As Long, targetLastRow As Long
    Dim sheetIndexes As Variant
    
    ' 指定要合并的工作表索引：第8和第9个
    sheetIndexes = Array(8, 9)
    
    ' 选择要合并的文件
    fnameList = Application.GetOpenFilename( _
        FileFilter:="Microsoft Excel Workbooks (*.xls;*.xlsx;*.xlsm),*.xls;*.xlsx;*.xlsm", _
        Title:="选择要合并的Excel文件", MultiSelect:=True)
    
    If VarType(fnameList) = vbBoolean Then
        MsgBox "未选择任何文件", vbExclamation, "合并Excel文件"
        Exit Sub
    End If
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Set wbkCurBook = ActiveWorkbook
    countFiles = 0
    
    For Each fnameCurFile In fnameList
        countFiles = countFiles + 1
        
        ' 后台读取源工作簿，不显示窗口
        Set wbkSrcBook = GetObject(fnameCurFile)
        
        ' 循环处理指定索引的工作表
        For Each idx In sheetIndexes
            Set srcSheet = wbkSrcBook.Sheets(idx)
            
            ' 获取源数据最后一行
            srcLastRow = srcSheet.Cells(srcSheet.Rows.Count, "A").End(xlUp).Row
            
            ' 检查目标工作簿是否存在同名工作表
            On Error Resume Next
            Set targetSheet = wbkCurBook.Sheets(srcSheet.Name)
            On Error GoTo 0
            
            ' 如果不存在则新建并复制表头
            If targetSheet Is Nothing Then
                Set targetSheet = wbkCurBook.Sheets.Add(After:=wbkCurBook.Sheets(wbkCurBook.Sheets.Count))
                targetSheet.Name = srcSheet.Name
                srcSheet.Rows(1).Copy targetSheet.Rows(1)
            End If
            
            ' 获取目标工作表空白起始行
            targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, "A").End(xlUp).Row + 1
            
            ' 复制源数据（跳过表头）
            srcSheet.Rows("2:" & srcLastRow).Copy targetSheet.Rows(targetLastRow)
            
            Set targetSheet = Nothing
        Next idx
        
        ' 关闭后台打开的源工作簿，不保存
        wbkSrcBook.Close SaveChanges:=False
        Set wbkSrcBook = Nothing
    Next fnameCurFile
    
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    
    MsgBox "已处理 " & countFiles & " 个文件" & vbCrLf & "完成指定工作表的数据追加合并", vbInformation, "合并完成"
End Sub

关键说明 #

• 无需打开源工作簿：使用GetObject方法后台读取源文件，不会弹出源工作簿窗口，符合需求
• 仅合并指定工作表：通过sheetIndexes = Array(8, 9)锁定第8、9个工作表，可直接修改数组调整目标索引
• 数据追加逻辑：
  1. 自动检查目标工作簿是否存在同名工作表，不存在则新建并复制表头
  2. 定位源数据末尾和目标工作表的空白行，将源数据（跳过表头）追加到对应工作表末尾
• 性能优化：关闭屏幕更新与自动计算，提升批量合并的运行速度

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