当前位置:office办公软件学习-Excel教程-PPT教程-Word教程 > EXCEL达人 > ExcelVBA > VBA应用 > 按指定关键词,一键汇总Excel分表数据

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

时间:2018-03-13 00:42来源:office办公达人 作者:office办公达人网 阅读:
【导读】:有时候,我们有多个EXCEl工作表,要汇总各分表中相同的关键词,手工汇总费力又会遗漏,如何实现按指定关键词,一键汇总Excel分表数据。

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




动画视频VBA代码如下:

Sub collect()
    '新浪微博@EXCELers,一键多表数据汇总
    Dim sht As Worksheet, rng As Range, k&, trow&
    Application.ScreenUpdating = False
    '取消屏幕更新,加快代码运行速度
    temp = InputBox("请输入需要合并的工作表所包含的关键词:", "提醒")
    If StrPtr(temp) = 0 Then Exit Sub
    '如果点击了inputbox的取消或者关闭按钮,则退出程序
    trow = Val(InputBox("请输入标题的行数", "提醒"))
    If trow < 0 Then MsgBox "标题行数不能为负数。", 64, "警告": Exit Sub
    '取得用户输入的标题行数,如果为负数,退出程序
    Cells.ClearContents
    '清空当前表数据
    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:=xlPasteValues
                Else
                    '否则,扣除标题行后再复制黏贴到总表,只黏贴数值
                    rng.Offset(trow).Copy
                    Cells(ActiveSheet.UsedRange.Rows.Count 1, 1).PasteSpecial Paste:=xlPasteValues
                End If
            End If
        End If
    Next
    [a1].Activate
    '激活A1单元格
    Application.ScreenUpdating = True
    '恢复屏幕刷新
End Sub

分享到
更多
顶一下
(1)
100%
踩一下
(0)
0%
------分隔线----------------------------
栏目列表
文章点击榜
推荐内容
最新文章
关于我们 | 联系我们 | 友情链接 | 版权声明 | 网站地图 | 帮助
网站为公益性网站,部分内容来源网络,如无意中侵犯了您的版权,请来信告知,我们会在第一时间处理
CopyRight© 2013-2018,www.officedoyen.com 版权所有   闽ICP备14010062号