EXCEL VBA合并当前工作簿的所有工作表sheet

将当前工作簿的所有工作表合并到到1个新的sheet,

新的sheet名称为合并

分为2个vba脚本，

不包含表头: 每个sheet的表头都是相同的,所以合并时不需要表头
包含表头

VBA代码通过KIMI生成

1 不包含表头(标题行)

复制代码

Sub 合并所有工作表_不含表头()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim destRow As Long
    Dim copyRange As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    '如已存在"合并"工作表，则删除
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets("合并")
    If Not wsNew Is Nothing Then wsNew.Delete
    On Error GoTo 0
    
    '新建"合并"工作表
    Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsNew.Name = "合并"
    
    destRow = 1   '目标行指针
    
    '遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "合并" Then
            If Application.WorksheetFunction.CountA(ws.Cells) > 0 Then
                '=== 关键修复：用 Find 取真正的最后一行/列 ===
                lastRow = ws.Cells.Find(What:="*", _
                                        After:=ws.Cells(1, 1), _
                                        SearchOrder:=xlByRows, _
                                        SearchDirection:=xlPrevious).Row
                lastCol = ws.Cells.Find(What:="*", _
                                        After:=ws.Cells(1, 1), _
                                        SearchOrder:=xlByColumns, _
                                        SearchDirection:=xlPrevious).Column
                
                '标题行：只在第一张工作表出现时复制
                If destRow = 1 Then
                    wsNew.Cells(destRow, 1).Value = "来源工作表"
                    ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol)).Copy _
                        Destination:=wsNew.Cells(destRow, 2)
                    destRow = destRow + 1
                End If
                
                '复制数据区（不含标题）
                Set copyRange = ws.Range(ws.Cells(2, 1), ws.Cells(lastRow, lastCol))
                copyRange.Copy wsNew.Cells(destRow, 2)
                
                '在A列写入来源工作表名称
                wsNew.Range(wsNew.Cells(destRow, 1), _
                            wsNew.Cells(destRow + copyRange.Rows.Count - 1, 1)).Value = ws.Name
                
                '移动目标行指针
                destRow = destRow + copyRange.Rows.Count
            End If
        End If
    Next ws
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "已完成合并，请查看"合并"工作表！", vbInformation
End Sub

2 包含表头(标题行)

复制代码

Sub 合并所有工作表_含表头()
    Dim ws As Worksheet, wsNew As Worksheet
    Dim lastRow As Long, lastCol As Long
    Dim destRow As Long
    Dim copyRange As Range
    
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    '如已存在"合并"工作表，则删除
    On Error Resume Next
    Set wsNew = ThisWorkbook.Worksheets("合并")
    If Not wsNew Is Nothing Then wsNew.Delete
    On Error GoTo 0
    
    '新建"合并"工作表
    Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    wsNew.Name = "合并"
    
    destRow = 1   '目标行指针
    
    '遍历所有工作表
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> "合并" Then
            If Application.WorksheetFunction.CountA(ws.Cells) > 0 Then
                '=== 用 Find 取真正的最后一行/列 ===
                lastRow = ws.Cells.Find(What:="*", _
                                        After:=ws.Cells(1, 1), _
                                        SearchOrder:=xlByRows, _
                                        SearchDirection:=xlPrevious).Row
                lastCol = ws.Cells.Find(What:="*", _
                                        After:=ws.Cells(1, 1), _
                                        SearchOrder:=xlByColumns, _
                                        SearchDirection:=xlPrevious).Column
                
                '复制当前工作表全部内容（含表头）
                Set copyRange = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, lastCol))
                copyRange.Copy wsNew.Cells(destRow, 2)   '从 B 列开始粘贴
                
                '在 A 列写入来源工作表名称
                wsNew.Range(wsNew.Cells(destRow, 1), _
                            wsNew.Cells(destRow + copyRange.Rows.Count - 1, 1)).Value = ws.Name
                
                '移动目标行指针
                destRow = destRow + copyRange.Rows.Count
            End If
        End If
    Next ws
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    MsgBox "已完成合并（含表头），请查看"合并"工作表！", vbInformation
End Sub