看到这个标题,是不是感觉似曾相识?
没错,前一段时间,我写过一篇推文VBA实用小代码(三),介绍的就是批量合并工作表。
但是,昨天自己处理数据的时候,发现还有值得优化的地方:
- 1.表尾去除功能。
- 2.合并之后的工作表可选择保留 or 不保留原格式。
Sub CollectSheets() Application.ScreenUpdating = False '取消屏幕更新,加快代码运行速度 Sheets(1).Select If Sheets(1).Name = "DownGather" Then Application.DisplayAlerts = False Sheets(1).Delete Application.DisplayAlerts = True End If Sheets.Add '新建一个汇总表 Sheets(1).Name = "DownGather" Dim SHT As Worksheet, Rng As Range, k&, trow&, temp temp = InputBox("请输入需要合并的工作表所包含的关键词(不区分大小写,不填默认全部合并):", "提醒") If StrPtr(temp) = 0 Then Exit Sub '如果点击了inputbox的取消或者关闭按钮,则退出程序 trow = Val(InputBox("请输入表头的行数,不填默认保留表头", "提醒")) drow = Val(InputBox("请输入表尾的行数,不填默认保留表尾", "提醒")) If trow < 0 Then MsgBox "表头行数不能为负数", 64, "警告": Exit Sub '取得用户输入的标题行数,如果为负数,退出程序 If drow < 0 Then MsgBox "表尾行数不能为负数", 64, "警告": Exit Sub '取得用户输入的标题行数,如果为负数,退出程序 a = MsgBox("是否保留原格式?", vbYesNo) If a = vbYes Then b = xlPasteAll Else b = xlPasteValues End If For Each SHT In Worksheets '循环读取表格 If SHT.Name <> ActiveSheet.Name Then '如果表格名称不等于当前表名则…… If InStr(1, SHT.Name, temp, vbTextCompare) Then '如果表中包含关键词则进行汇总动作(不区分关键词字母大小写) Set Rng = SHT.UsedRange '定义rng为表格已用区域 k = k + 1 '累计K值 If k = 1 Then '如果是首个表格,则K为1,则把标题行一起复制到汇总表 Rng.Copy [a1].PasteSpecial Paste:=b Else '否则,扣除标题行后再复制黏贴到总表 Rng.Offset(trow).Copy Cells(ActiveSheet.UsedRange.Rows.Count + 1 - drow, 1).PasteSpecial Paste:=b End If End If End If Next [a1].Activate '激活A1单元格 Application.ScreenUpdating = True '恢复屏幕刷新End Sub
不懂 VBA ?没关系,只要学会复制代码运行就 OK ,参考推文:
VBA实用小代码(一)
小贴士:
▎1.个人建议处理数据的时候还是不保留原格式比较好,可以减少一些隐藏的错误。
▎2.由于限制,动图可能比较快,建议多看几遍。
希望这篇文章对你有用。: )
资源部分源于网络,仅供学习&交流,禁商用,侵删。 - END - 往期精彩: 01. VBA实用小代码(九):批量撤销合并单元格 02. VBA实用小代码(八):批量合并单元格 03. VBA实用小代码(七):添加返回目录按钮