当我们有一张表里面有很多sheet 具有相同的表结构，如果需要汇总到一张表中，那么我们可以借助VBA 去实现汇总自动化
示例1 ：
文章来源：https://www.toymoban.com/news/detail-661347.html
Sub 复制所有工作表内容()
Dim ws As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
' 设置目标表格，即要将所有工作表内容复制到的表格
Set targetSheet = ThisWorkbook.Sheets("汇总")
' 清除目标表格中已有的数据
targetSheet.Rows("2:1000000").Clear
' 添加目标表格的表头
targetSheet.Range("A1:C1").Value = ThisWorkbook.Sheets("汇总").Range("A1:C1").Value
' 循环遍历每个工作表
For Each ws In ThisWorkbook.Sheets
' 排除指定的工作表
If ws.Name <> "汇总" Then
' 获取源工作表最后一行的行号
lastRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
' 复制源工作表的 A 到 M 列内容到目标表格中的下一行
ws.Range("A2:M" & lastRow).Copy targetSheet.Cells(targetSheet.Cells(Rows.Count, "A").End(xlUp).Row + 1, "A")
End If
Next ws
MsgBox "所有工作表内容已复制到目标表格中！", vbInformation
End Sub
运行结果如下：
示例2 ：
如下图所示
汇总的时候需要插入一个新列，填入各个sheetname ；
各个sheet 有合并单元格，汇总之后需要拆分合并单元格并填充空白单元格；
各个sheet 由几个单独表格组成，并且表格之间有Note 和空白行，汇总之后需要删除这些note 或者空白行
文章来源地址https://www.toymoban.com/news/detail-661347.html
Sub 复制所有工作表内容()
Dim ws As Worksheet
Dim targetSheet As Worksheet
Dim lastRow As Long
Dim rng As Range
Dim cell As Range
Dim deleteRange As Range
Dim i As Integer
' 设置目标表格，即要将所有工作表内容复制到的表格
Set targetSheet = ThisWorkbook.Sheets("Sheet1")
' 清除目标表格中已有的数据
targetSheet.Rows("2:1048000").Select
Selection.Delete Shift:=xlUp
' 添加目标表格的表头
Sheets("全国").Select
Range("E2:AU2").Select
Selection.Copy
Sheets("Sheet1").Select
Range("F1:AV1").Select
ActiveSheet.Paste
' 循环遍历每个工作表
For Each ws In ThisWorkbook.Sheets
' 排除指定的工作表
If ws.Name <> "Sheet1" Then
' 获取源工作表最后一行的行号
lastRow = ws.Cells(1048000, "D").End(xlUp).Row
sheetName = ws.Name
ws.Columns(1).Insert Shift:=xlToRight '在第一列之前插入新的一列
'将对应的工作表名称填充到新插入的列中
ws.Range("A3:A" & lastRow).Value = sheetName
' 复制源工作表的 A 到 AU 列内容到目标表格中的下一行
ws.Range("A3:AV" & lastRow).Copy targetSheet.Cells(targetSheet.Cells(1048000, "E").End(xlUp).Row + 1, "A")
End If
Next ws
Set ws = ThisWorkbook.Worksheets("Sheet1")
lastRow = ws.Cells(1048000, "A").End(xlUp).Row
Set rng = ws.Range("B2:AV" & lastRow)
For Each cell In rng
If InStr(1, cell.Value, "Note", vbTextCompare) > 0 Then
If deleteRange Is Nothing Then
Set deleteRange = cell.EntireRow
Else
Set deleteRange = Union(deleteRange, cell.EntireRow)
End If
End If
Next cell
For Each cell In rng
If InStr(1, cell.Value, "销售额", vbTextCompare) > 0 Then
If deleteRange Is Nothing Then
Set deleteRange = cell.EntireRow
Else
Set deleteRange = Union(deleteRange, cell.EntireRow)
End If
End If
Next cell
For Each cell In rng
If InStr(1, cell.Value, "Jan", vbTextCompare) > 0 Then
If deleteRange Is Nothing Then
Set deleteRange = cell.EntireRow
Else
Set deleteRange = Union(deleteRange, cell.EntireRow)
End If
End If
Next cell
If Not deleteRange Is Nothing Then
deleteRange.Delete
End If
'删除空白的整行
lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row '获取最后一行的行号
Set rng = ws.Range("A2:AV" & lastRow) '替换为你要操作的区域范围
For i = lastRow To 1 Step -1
If Application.WorksheetFunction.CountA(rng.Rows(i)) = 1 Then
rng.Rows(i).Delete
End If
Next i
Dim m As Integer
Dim n As Integer
For i = 1 To lastRow
'判断该单元格是否是合并单元格
If Cells(i, 2).MergeCells = True Then
m = Cells(i, 2).MergeArea.Count
n = Cells(i, 2).MergeArea.Rows.Count
'记录合并单元格的个数
Range(Cells(i, 2), Cells(i + m - 1, 2)).UnMerge '拆分单元格
Range(Cells(i, 2), Cells(i + m - 1, 2)).FillDown '填充单元格
i = i + m - 1
End If
Next
For i = 1 To lastRow
'判断该单元格是否是合并单元格
If Cells(i, 3).MergeCells = True Then
m = Cells(i, 3).MergeArea.Count
n = Cells(i, 3).MergeArea.Rows.Count
'记录合并单元格的个数
Range(Cells(i, 3), Cells(i + m - 1, 3)).UnMerge '拆分单元格
If m > 1 And n > 1 Then
Range(Cells(i, 3), Cells(i + m - 1, 3)).FillDown '填充单元格
End If
i = i + m - 1
End If
Next
MsgBox "所有工作表内容已复制到目标表格中！", vbInformation
End Sub
到了这里，关于Excel VBA 复制除指定工作表外所有的工作表的内容到一张工作表中的文章就介绍完了。如果您还想了解更多内容，请在右上角搜索TOY模板网以前的文章或继续浏览下面的相关文章，希望大家以后多多支持TOY模板网！
