合并多份同结构Excel文件对应工作表的技术问询

我懂你现在的困扰——原来的VBA代码只能合并每个文件的当前活动工作表，但你需要的是把多个结构一致的Excel文件里的同名工作表批量合并到一起。别担心，我给你调整后的代码，完美解决这个需求：

Sub MergeSameNameWorksheets()
    Dim mergeObj As Object, dirObj As Object, filesObj As Object, everyObj As Object
    Dim sourceBook As Workbook, targetBook As Workbook
    Dim sourceSheet As Worksheet, targetSheet As Worksheet
    Dim lastRow As Long, targetLastRow As Long
    Dim sheetName As String
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    ' 弹出文件夹选择框，让你选要合并的文件所在文件夹
    Set mergeObj = CreateObject("Scripting.FileSystemObject")
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "选择包含待合并Excel文件的文件夹"
        If .Show <> -1 Then
            MsgBox "未选择文件夹，程序退出"
            GoTo Cleanup
        End If
        Set dirObj = mergeObj.GetFolder(.SelectedItems(1))
    End With
    
    ' 创建一个新工作簿，用来存合并后的结果
    Set targetBook = Workbooks.Add
    
    ' 遍历文件夹里的所有Excel文件
    Set filesObj = dirObj.Files
    For Each everyObj In filesObj
        ' 只处理xls/xlsx格式，同时跳过我们刚创建的目标工作簿
        If everyObj.Name Like "*.xls*" And everyObj.Path <> targetBook.FullName Then
            Set sourceBook = Workbooks.Open(everyObj.Path)
            
            ' 逐个遍历当前源文件里的所有工作表
            For Each sourceSheet In sourceBook.Sheets
                sheetName = sourceSheet.Name
                
                ' 检查目标工作簿里有没有同名的工作表
                On Error Resume Next
                Set targetSheet = targetBook.Sheets(sheetName)
                On Error GoTo 0
                
                ' 分两种情况处理：没有同名表就复制整个表；有就追加数据
                If targetSheet Is Nothing Then
                    sourceSheet.Copy After:=targetBook.Sheets(targetBook.Sheets.Count)
                    Set targetSheet = targetBook.Sheets(targetBook.Sheets.Count)
                Else
                    ' 找到源表最后一行有数据的位置
                    lastRow = sourceSheet.Cells(sourceSheet.Rows.Count, 1).End(xlUp).Row
                    ' 找到目标表最后一行空行的位置（跳过表头）
                    targetLastRow = targetSheet.Cells(targetSheet.Rows.Count, 1).End(xlUp).Row + 1
                    ' 复制源表数据到目标表
                    sourceSheet.Range("A2:" & sourceSheet.Cells(lastRow, sourceSheet.Columns.Count).Address).Copy _
                        targetSheet.Range("A" & targetLastRow)
                End If
                
                Set targetSheet = Nothing ' 重置变量，避免后续出错
            Next sourceSheet
            
            sourceBook.Close SaveChanges:=False ' 关闭源文件，不保存任何修改
        End If
    Next everyObj
    
    MsgBox "同名工作表合并完成！"
    
Cleanup:
    ' 恢复Excel的默认设置
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    ' 释放所有对象变量
    Set mergeObj = Nothing
    Set dirObj = Nothing
    Set filesObj = Nothing
    Set everyObj = Nothing
    Set sourceBook = Nothing
    Set targetBook = Nothing
    Set sourceSheet = Nothing
    Set targetSheet = Nothing
End Sub

关键说明&注意事项 #

• 核心改进：不再局限于活动工作表，会遍历每个源文件里的所有工作表，自动匹配同名表进行合并
• 数据追加逻辑：默认跳过第1行的表头（如果你的表头行数不同，把代码里的A2改成对应起始行就行）
• 操作友好性：加入了文件夹选择对话框，不用手动修改代码里的文件路径
• 运行优化：关闭了屏幕更新和弹窗提示，运行速度更快，也不会被弹窗打断
• 前提条件：确保所有要合并的同名工作表结构完全一致（列数、列顺序相同），否则数据会错位
• 安全建议：运行前建议备份所有源文件，避免意外情况

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