文科生自学VBA-批量汇总所有Sheet数据

--世界上只有一种真正的英雄主义,就是看清生活的真相之后依然热爱生活，学习编程成就更好的自己--

微软公司Office软件在商业办公领域一直占据着主流和主导地位，其中Excel在数据处理和分析领域有着强大的影响力，大部分人在经历几年职场历练后可以熟练的使用Excel函数和透视表功能，基本可以轻松完成绝大多数工作和任务。但实际上Office的强大和独特之处还在于VBA，因为VBA能够胜任好多个性化二次开发，减少重复机械劳动从而实现办公自动化，开发效率高且开发周期短，尤其对于Excel重度使用者来说会了VBA简直就是如虎添翼啊！！！

最近一直分享Python学习过程的知识总结和相关经验，今后也会专门写些文章讲讲VBA的基础知识和应用场景，也满足一些小伙伴们的好奇心，毕竟VBA算是比较“古老”和“小众”的语言，并没有像Python那么火爆流行。今天介绍的案例是：如何批量汇总同一个Workbook里所有Sheet数据，下面看截图：

语文成绩数据：

数学成绩数据：

看到该Excel文件里共有5个Sheet，所有科目的数据结构都是一样的，但部分数据会有缺失，如何把这些数据批量合并存入一个新建的Sheet("汇总")里呢？

看看用VBA如何解决吧：

1.判断该文件是否存有"汇总"Sheet,如无则新建，如有则删除后再新建：

代码如下：

Sub 判断和创建汇总数据SHEET()
Application.ScreenUpdating = False
'定义程序开始时间点
Start_Time = Time
Dim i As Long, Key1
'创建一个字典将所有SHEET名存入其中
Set dic1 = CreateObject("scripting.dictionary")
For i = 2 To Sheets.Count
    Key1 = Sheets(i).Name
    dic1(Key1) = ""
    Debug.Print Sheets(i).Name
Next i
'通过字典中是否存在方法来判断，有汇总则删除再新建，没有汇总SHEET则创建
If dic1.Exists("汇总") Then
    On Error Resume Next
    'MsgBox "汇总已存在!!"
    Application.DisplayAlerts = False
    Sheets("汇总").Delete
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "汇总"
    Sheets(1).Select
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A1")
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A2")
    Sheets("汇总").Select
Else:
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "汇总"
    Sheets(1).Select
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A1")
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A2")
    Sheets("汇总").Select
End If
'查看当前SHEET个数
Debug.Print Sheets.Count
'计算程序运行消耗时间
Running_Time = Time - Start_Time
Debug.Print Running_Time
Application.ScreenUpdating = True
End Sub

这里把所有Sheet名字装入一个字典dic1里，通过字典方法判定汇总Sheet是否存在；在写VBA代码时如果拿不准就用Debug.Print方法来看运行效果，在立即窗口中显示结果出来，方便后续调试和测试程序；新建Sheet的方法一般是使用Sheets.Add(After:=Sheets(Sheets.Count)).Name = "XX";显示程序运行时间一般通过Time方法来计算程序；在这段代码后半部分使用了End(xlToRight)方法来锚定要复制区域的最右端，定位复制了sheet1里字段头，同时复制了两行字段头方便后续使用offset(1,0)方法来拼接数据。

2.循环遍历所有sheet数据，如发现缺失数据则填充ID字符，之后合并数据：

代码如下：

Sub 批量合并数据()
Application.ScreenUpdating = False
'定义程序开始时间点
Start_Time = Time
'查看当前SHEET个数
Debug.Print Sheets.Count
'循环遍历每个SHEET找到有空缺行数据并填充ID值
For Each sht In Worksheets
    Dim l As Long, lr As Long
    lr = sht.UsedRange.Rows.Count
    For l = 1 To lr
    If sht.Range("A" & l) = "" Then
        sht.Range("A" & l) = "ID"
    End If
    Next l
Next
'循环遍历把所有非汇总SHEET数据复制到汇总SHEET里
Dim i As Long
For i = 1 To Sheets.Count
    If Sheets(i).Name <> "汇总" Then
        Sheets(i).Select
        Sheets(i).UsedRange.Copy Sheets("汇总").Range("A1").End(xlDown).Offset(1, 0)
    End If
Next i
Sheets("汇总").Select
'计算程序运行消耗时间
Running_Time = Time - Start_Time
Debug.Print Running_Time
'通过消息窗口提示程序消耗时间
'MsgBox Running_Time
Application.ScreenUpdating = True
End Sub

首先要解决的是缺失数据问题，因为在复制数据时使用End(xlDown)方法，如果仍然有空缺数据会发生错误(会导致缺失下面的数据覆盖掉)，使用For Each sht in Worksheets方法实现了遍历所有Sheet并根据A列字段名ID来填补空行数据；使用了Offset(1,0)方法来进行逐个向最下面找第一空白位置来填充数据。

3.删除汇总数据中多余数据得到最终结果：

代码如下：

Sub 删除多余行()
Application.ScreenUpdating = False
'定义程序开始时间点
Start_Time = Time
Sheets("汇总").Select
Dim i As Long, lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
For i = lr To 2 Step -1
    If Range("A" & i) = "ID" Then
        Rows(i).Delete
    End If
Next i
Running_Time = Time - Start_Time
Debug.Print Running_Time
'通过消息窗口提示程序消耗时间
'MsgBox Running_Time
Application.ScreenUpdating = True
End Sub

使用了If和Delete方法来逐行删除多余数据，并以A列ID值是否存在作为判断依据，因为是结合了该数据集本身的特征，另外需要强调的是删除多余行最好从最后一行开始向上进行，在Step -1这里体现出来了。

整体代码如下：

Sub 判断和创建汇总数据SHEET()
Application.ScreenUpdating = False
'定义程序开始时间点
Start_Time = Time
'查看当前SHEET个数
Dim i As Long, Key1
'创建一个字典将所有SHEET名存入其中
Set dic1 = CreateObject("scripting.dictionary")
For i = 2 To Sheets.Count
    Key1 = Sheets(i).Name
    dic1(Key1) = ""
    Debug.Print Sheets(i).Name
Next i
'通过字典中是否存在方法来判断，有汇总则不需要新建，没有汇总SHEET则创建
If dic1.Exists("汇总") Then
    On Error Resume Next
    'MsgBox "汇总已存在!!"
    Application.DisplayAlerts = False
    Sheets("汇总").Delete
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "汇总"
    Sheets(1).Select
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A1")
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A2")
    Sheets("汇总").Select
Else:
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "汇总"
    Sheets(1).Select
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A1")
    Sheets(1).Range(Range("A1"), Range("A1").End(xlToRight)).Copy Sheets("汇总").Range("A2")
    Sheets("汇总").Select
End If
'查看当前SHEET个数
Debug.Print Sheets.Count
'计算程序运行消耗时间
Running_Time = Time - Start_Time
Debug.Print Running_Time
Application.ScreenUpdating = True
End Sub

Sub 批量合并数据()
Application.ScreenUpdating = False
'定义程序开始时间点
Start_Time = Time
'查看当前SHEET个数
Debug.Print Sheets.Count
'循环遍历每个SHEET找到有空缺行数据并填充ID值
For Each sht In Worksheets
    Dim l As Long, lr As Long
    lr = sht.UsedRange.Rows.Count
    For l = 1 To lr
    If sht.Range("A" & l) = "" Then
        sht.Range("A" & l) = "ID"
    End If
    Next l
Next
'循环遍历把所有非汇总SHEET数据复制到汇总SHEET里
Dim i As Long
For i = 1 To Sheets.Count
    If Sheets(i).Name <> "汇总" Then
        Sheets(i).Select
        Sheets(i).UsedRange.Copy Sheets("汇总").Range("A1").End(xlDown).Offset(1, 0)
    End If
Next i
Sheets("汇总").Select
'计算程序运行消耗时间
Running_Time = Time - Start_Time
Debug.Print Running_Time
'通过消息窗口提示程序消耗时间
'MsgBox Running_Time
Application.ScreenUpdating = True
End Sub

Sub 删除多余行()
Application.ScreenUpdating = False
'定义程序开始时间点
Start_Time = Time
Sheets("汇总").Select
Dim i As Long, lr As Long
lr = ActiveSheet.UsedRange.Rows.Count
For i = lr To 2 Step -1
    If Range("A" & i) = "ID" Then
        Rows(i).Delete
    End If
Next i
Running_Time = Time - Start_Time
Debug.Print Running_Time
'通过消息窗口提示程序消耗时间
'MsgBox Running_Time
Application.ScreenUpdating = True
End Sub

Sub 汇总数据任务()
Application.ScreenUpdating = False
Call 判断和创建汇总数据SHEET
Call 批量合并数据
Call 删除多余行
Application.ScreenUpdating = True
End Sub

把代码块逐步执行，使用Call方法按顺序写好就行了，大家也试试吧！！！

END

我为人人，人人为我！！欢迎大家关注，点赞和转发！！！

~~人生不是赛场，梦想不容退场~~不断努力学习蜕变出一个更好的自己，不断分享学习路上的收获和感悟帮助他人成就自己！！！