举个例子，
如下图所示。一个工作簿包含了多张工作表，每张工作表的标题行数和排列顺序是相同的，不过数据区域可能包含合并单元格……
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
网友评论