申请付费网站百度网络科技有限公司

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

分为2个vba脚本 ，

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

VBA代码通过KIMI生成

1 不包含表头(标题行)

Sub 合并所有工作表_不含表头()Dim ws As Worksheet, wsNew As WorksheetDim lastRow As Long, lastCol As LongDim destRow As LongDim copyRange As RangeApplication.ScreenUpdating = FalseApplication.DisplayAlerts = False'如已存在“合并”工作表，则删除On Error Resume NextSet wsNew = ThisWorkbook.Worksheets("合并")If Not wsNew Is Nothing Then wsNew.DeleteOn Error GoTo 0'新建“合并”工作表Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsNew.Name = "合并"destRow = 1   '目标行指针'遍历所有工作表For Each ws In ThisWorkbook.WorksheetsIf ws.Name <> "合并" ThenIf Application.WorksheetFunction.CountA(ws.Cells) > 0 Then'=== 关键修复：用 Find 取真正的最后一行/列 ===lastRow = ws.Cells.Find(What:="*", _After:=ws.Cells(1, 1), _SearchOrder:=xlByRows, _SearchDirection:=xlPrevious).RowlastCol = ws.Cells.Find(What:="*", _After:=ws.Cells(1, 1), _SearchOrder:=xlByColumns, _SearchDirection:=xlPrevious).Column'标题行：只在第一张工作表出现时复制If destRow = 1 ThenwsNew.Cells(destRow, 1).Value = "来源工作表"ws.Range(ws.Cells(1, 1), ws.Cells(1, lastCol)).Copy _Destination:=wsNew.Cells(destRow, 2)destRow = destRow + 1End 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.CountEnd IfEnd IfNext wsApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "已完成合并，请查看“合并”工作表！", vbInformation
End Sub

2 包含表头(标题行)

Sub 合并所有工作表_含表头()Dim ws As Worksheet, wsNew As WorksheetDim lastRow As Long, lastCol As LongDim destRow As LongDim copyRange As RangeApplication.ScreenUpdating = FalseApplication.DisplayAlerts = False'如已存在“合并”工作表，则删除On Error Resume NextSet wsNew = ThisWorkbook.Worksheets("合并")If Not wsNew Is Nothing Then wsNew.DeleteOn Error GoTo 0'新建“合并”工作表Set wsNew = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))wsNew.Name = "合并"destRow = 1   '目标行指针'遍历所有工作表For Each ws In ThisWorkbook.WorksheetsIf ws.Name <> "合并" ThenIf Application.WorksheetFunction.CountA(ws.Cells) > 0 Then'=== 用 Find 取真正的最后一行/列 ===lastRow = ws.Cells.Find(What:="*", _After:=ws.Cells(1, 1), _SearchOrder:=xlByRows, _SearchDirection:=xlPrevious).RowlastCol = 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.CountEnd IfEnd IfNext wsApplication.DisplayAlerts = TrueApplication.ScreenUpdating = TrueMsgBox "已完成合并（含表头），请查看“合并”工作表！", vbInformation
End Sub