工作薄|表合并

Sub 合并()
   
   '————————————————————————————————————————
    '自定义各数据类型
    Dim FileToOpen As Variant
    Dim i, RW, CL, RW_1, CL_1 As Long
    Dim sht As Worksheet
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    '判断工作簿中是否包含《汇总表》，如过不存在就新增一个
    On Error Resume Next
    ThisWorkbook.Sheets.Add after:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
    ActiveSheet.Name = "汇总表"
    If Err.Number > 0 Then ActiveSheet.Delete
    On Error GoTo 0
    
    '多选或单选要合并的工作薄/表，如果没有选择任何文件则退出
    FileToOpen = Application.GetOpenFilename("Excel文件,*.xl*", , "请选择要合并的多个工作簿/表", , True)
    If VBA.TypeName(FileToOpen) = "Boolean" Then
        MsgBox "没有选择文件": Exit Sub
    End If
    
    '合并过程，遍历选中的每个工作薄、工作表，在首列增加来源的工作薄+工作表名
    On Error Resume Next
    For i = 1 To UBound(FileToOpen)
         Workbooks.Open Filename:=FileToOpen(i)
         For Each sht In ActiveWorkbook.Sheets
            sht.Activate
            RW_1 = sht.UsedRange.Rows.Count
            CL_1 = sht.UsedRange.Columns.Count
            If RW_1 + CL_1 > 0 Then
                RW = ThisWorkbook.Sheets("汇总表").UsedRange.Rows.Count
                If RW > 1 Then
                    ActiveSheet.Cells(1, 1).Resize(RW_1, CL_1).Copy _
                        Destination:=ThisWorkbook.Sheets("汇总表").Cells(RW + 1, 2)
                    ThisWorkbook.Sheets("汇总表").Cells(RW + 1, 1) = "来源表"
                    ThisWorkbook.Sheets("汇总表").Cells(RW + 2, 1).Resize(RW_1 - 1, 1) = ActiveWorkbook.Name & "-" & sht.Name
                Else
                    ActiveSheet.Cells(1, 1).Resize(RW_1, CL_1).Copy _
                        Destination:=ThisWorkbook.Sheets("汇总表").Cells(1, 2)
                    ThisWorkbook.Sheets("汇总表").Cells(1, 1) = "来源表"
                    ThisWorkbook.Sheets("汇总表").Cells(2, 1).Resize(RW_1 - 1, 1) = ActiveWorkbook.Name & "-" & sht.Name
                End If
            End If
         Next sht
         ActiveWorkbook.Close
     Next i
    
    On Error GoTo 0
    MsgBox "汇总表完成"
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

1：将多个工作薄中的多个表拼接合并为一个工作表

2：适用于数据较为规整的数据，多个工作表直接上下拼接合并

3：若希望自动对齐以首行为标题行的列，单击 多工作薄|表合并 在线执行合并;

源码视频演示

工作簿|表合并

目录