Excel VBA 复制除指定工作表外所有的工作表的内容到一张工作表中

当我们有一张表里面有很多sheet 具有相同的表结构，如果需要汇总到一张表中，那么我们可以借助VBA 去实现汇总自动化

示例1 ：

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 或者空白行

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