按指定关键词，一键汇总Excel分表数据

成长路上除了

有时候，我们有多个EXCEl工作表，要汇总各分表中相同的关键词，手工汇总费力又会遗漏，如何实现按指定关键词，一键汇总Excel分表数据。

动画视频VBA代码如下：

1. Sub collect()
   
2.     Dim sht As Worksheet, rng As Range, k&, trow&
   
3.     Application.ScreenUpdating = False
   
4.     '取消屏幕更新，加快代码运行速度
   
5.     temp = InputBox("请输入需要合并的工作表所包含的关键词：", "提醒")
   
6.     If StrPtr(temp) = 0 Then Exit Sub
   
7.     '如果点击了inputbox的取消或者关闭按钮，则退出程序
   
8.     trow = Val(InputBox("请输入标题的行数", "提醒"))
   
9.     If trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
   
10.     '取得用户输入的标题行数，如果为负数，退出程序
    
11.     Cells.ClearContents
    
12.     '清空当前表数据
    
13.     For Each sht In Worksheets
    
14.     '循环读取表格
    
15.         If sht.Name <> ActiveSheet.Name Then
    
16.         '如果表格名称不等于当前表名则……
    
17.             If InStr(1, sht.Name, temp, vbTextCompare) Then
    
18.            '如果表中包含关键词则进行汇总动作(不区分关键词字母大小写）
    
19.                 Set rng = sht.UsedRange
    
20.                 '定义rng为表格已用区域
    
21.                 k = k 1
    
22.                 '累计K值
    
23.                 If k = 1 Then
    
24.                 '如果是首个表格，则K为1，则把标题行一起复制到汇总表
    
25.                     rng.Copy
    
26.                     [a1].PasteSpecial Paste:=xlPasteValues
    
27.                 Else
    
28.                     '否则，扣除标题行后再复制黏贴到总表，只黏贴数值
    
29.                     rng.Offset(trow).Copy
    
30.                     Cells(ActiveSheet.UsedRange.Rows.Count 1, 1).PasteSpecial Paste:=xlPasteValues
    
31.                 End If
    
32.             End If
    
33.         End If
    
34.     Next
    
35.     [a1].Activate
    
36.     '激活A1单元格
    
37.     Application.ScreenUpdating = True
    
38.     '恢复屏幕刷新
    
39. End Sub
    
40. 
    

复制代码