汇总分表成总表，并保留源表格式？只需一键！

作者：看见星光

 微博：EXCELers / 知识星球：Excel

嗨，大家好，我是星光。

之前分享过一段VBA小代码，作用是将多个工作表的数据汇总成总表，但那段代码并没有保留原工作表的格式。在实际工作中，有些朋友是需要保留源表格式的。

动画演示效果如下：

以下代码，在将各工作表数据汇总的同时，也保留了源表格式，且复制即可使用。

Sub CollectDataFromShtFormat() Dim sht As Worksheet, rng As Range, k As Long Dim nTitleCount As Long, x As Long, shtA As Worksheet On Error Resume Next nTitleCount = Val(InputBox('请输入标题的行数', '提醒', 1)) '用户输入标题行行数，默认为1 If nTitleCount < 0 Then MsgBox '标题行数不能为负数。', 64, '提示': Exit Sub Application.ScreenUpdating = False '取消屏幕刷新 Set shtA = Worksheets('我的汇总表') '指定放置汇总数据的工作表 If Err Then '如果当前工作簿不存在shtA则新建一张 Set shtA = Worksheets.Add shtA.Name = '我的汇总表' End If shtA.Select Cells.Clear '清空当前表数据 For Each sht In Worksheets '遍历工作表 If sht.Name <> ActiveSheet.Name Then '如果工作表名称不等于当前表名则进行汇总动作…… Set rng = sht.UsedRange '已用区域 k = k + 1 '计数器 If k = 1 Then '如果是首个表格，则K为1，则把标题行一起复制到汇总表 sht.Cells.Copy: Range('a1').PasteSpecial Paste:=xlPasteFormats '保留格式 rng.Copy Range('a1') Else '否则，扣除标题行后再复制黏贴到总表 x = Cells.Find('*', _ LookIn:=xlFormulas, SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious).Row + 1 '最后存在数据的行 rng.Offset(nTitleCount).Copy Cells(x, 1) End If End If Next Range('a1').Select Application.ScreenUpdating = True '恢复屏幕刷新 MsgBox '汇总OK，一共汇总了：' & k & '张工作表'End Sub

白鹤亮翅，打完收工。