如何快速汇总多sheet表数据成总表

举个例子，

如下图所示。一个工作簿包含了多张工作表，每张工作表的标题行数和排列顺序是相同的，不过数据区域可能包含合并单元格……

image

使用以下代码可以将多表数据汇总，并保留源表的合并单元格格式等。

Sub GetShData1()
    Dim sht As Worksheet, rng As Range
    Dim k As Long, intLastRow As Long
    With Application '取消屏幕刷新等
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
    End With
    Cells.Clear '清空数据
    For Each sht In Worksheets '遍历表
        If sht.Name <> ActiveSheet.Name Then
            Set rng = sht.UsedRange '已使用单元格区域
            If IsEmpty(rng) = False Then '判断是否空表
                k = k + 1 '计数器
                If k = 1 Then
                    rng.Copy Range("a1") '复制粘贴数据
                Else
                    intLastRow = Cells.Find("*", _
                        LookIn:=xlFormulas, SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious).Row + 1
                    rng.Copy Cells(intLastRow, 1) '粘贴数据
                End If
            End If
        End If
    Next
    With Application '恢复屏幕刷新
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
    End With
    MsgBox "已汇总：" & k & "个工作表。"
End Sub

上述代码虽然解决了多表汇总的问题，但比较简陋，有很多细节问题未能正确处理；比如……

1 丨
它将每张表的标题行都复制到了汇总表，实际上，只需要保留首张工作表的标题行就可以了。
2 丨
如果分表处于筛选状态，直接复制粘贴会造成数据遗漏，毕竟绝大部分Excel版本都是默认只复制筛选状态下可见单元格的数据。
3 丨
汇总结果未提供数据来源工作表的表名。为了体现社会主义核心价值观，敬业、诚心、友善……我们最好还是增加一个字段，显示工作表名称。

image

进化后的代码如下……

Sub GetShData()
    Dim sht As Worksheet, rngData As Range
    Dim i As Long, intLastRow As Long
    Dim intTitCount, intYesOrNo As String
    Dim rngLast As Range, rngFirst As Range
    intTitCount = getTitCount() '获取用户输入的标题行数
    If intTitCount = False Then Exit Sub
    intYesOrNo = MsgBox("是否需要保留源表格式、公式等？", vbYesNo)
    Call disAppSet '取消屏幕刷新，公式重算等
    Cells.Clear '清空当前表数据
    For Each sht In Worksheets '遍历工作表
        If sht.Name <> ActiveSheet.Name Then
            Set rngData = sht.UsedRange '有效单元格区域
            If IsEmpty(rngData) = False Then '判断工作表是否非空
                If sht.AutoFilterMode = True Then
                    sht.Cells.AutoFilter '取消筛选，避免数据复制遗漏
                End If
                k = k + 1 '计数器
                If k = 1 Then '如果是第一张工作表
                    rngData.Copy '复制源表单元格
                    Range("b1").PasteSpecial xlPasteColumnWidths '粘贴列宽
                    Call rngPaste(Range("b1"), intYesOrNo) '粘贴数据
                    Set rngFirst = Cells(1, 1) '开始单元格
                    intLastRow = GetIntLastRow '结束行
                    Set rngLast = Cells(intLastRow, 1) '结束单元格
                    Range(rngFirst, rngLast) = sht.Name '填充工作表名称
                Else
                    rngData.Offset(intTitCount).Copy '扣除标题复制
                    Call rngPaste(Cells(rngLast.Row + 1, 2), intYesOrNo)
                    intLastRow = GetIntLastRow
                    Set rngFirst = rngLast.Offset(1) '开始单元格
                    Set rngLast = Cells(intLastRow, 1) '结束单元格
                    Range(rngFirst, rngLast) = sht.Name '填充工作表名称
                End If
            End If
        End If
    Next
    Call rngFormat(intTitCount)
    Call reAppSet '恢复屏幕刷新等
    MsgBox "一共汇总了" & k & "张工作表。"
End Sub

'获取用户输入的标题行数
Function getTitCount()
    Dim intTitCount
    intTitCount = InputBox("请输入标题行的行数", _
                        Title:="公众号Excel星球", _
                        Default:=1)
    If StrPtr(intTitCount) = False Then
        getTitCount = False
        Exit Function
    End If
    If IsNumeric(intTitCount) = False Then
        MsgBox "标题行的行数只能输入数字。"
        getTitCount = False
        Exit Function
    End If
    If intTitCount < 0 Then
        MsgBox "标题行数不能为负数。"
        getTitCount = False
        Exit Function
    End If
    getTitCount = intTitCount
End Function

'取消屏幕刷新，公式重算等
Sub disAppSet()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
End Sub

'恢复屏幕刷新等
Sub reAppSet()
    With Application
        .ScreenUpdating = True
        .Calculation = xlCalculationAutomatic
        .DisplayAlerts = True
    End With
End Sub

'最后存在数据的行
Function GetIntLastRow()
    GetIntLastRow = Cells.Find("*", _
        LookIn:=xlFormulas, SearchOrder:=xlByRows, _
        SearchDirection:=xlPrevious).Row
End Function

'粘贴子过程
'两个参数
'一个粘贴区域起始单元格
'一个粘贴的方式，是否只粘贴数值
Sub rngPaste(ByVal rng As Range, ByVal intYesOrNo As Long)
    If intYesOrNo = 6 Then '是否保留源表格式
        rng.PasteSpecial xlPasteAll '粘贴全部
    Else
        rng.PasteSpecial xlPasteValues '粘贴数值
    End If
    'Application.CutCopyMode = False
End Sub

'将B列格式复制到A列
Sub rngFormat(ByVal intTitCount As Long)
    Range("b:b").Copy
    With Range("a1")
        .PasteSpecial xlPasteFormats '粘贴B列格式
        .Value = "工作表名" '填写工作表来源
        .Resize(intTitCount, 1).Merge '合并多行标题
        .HorizontalAlignment = xlCenter '水平居中
        .VerticalAlignment = xlCenter '垂直居中
        .EntireColumn.AutoFit '自动列宽
        .Select
    End With
End Sub

打完收工！！

原文链接:

https://mp.weixin.qq.com/s/0pxi_xn-a8A10f7mM-YxEw

示例文件下载，百度网盘▼

https://pan.baidu.com/s/1MT-r6M7LLBbftZYlCPlurQ
提取码: sm2a