VBA学习笔记6：将多个工作表中满足条件的数据汇总到同一个工作表

需求：现有3个班级的成绩表，需要筛选出成绩>=90分的成绩及科目。

需要汇总如下：

脚本如下：

Sub 筛选满足条件的数据()
'将每班分数>=90分的同学及相关科目筛选出来Dim sht As Worksheet '存储每个班的表Dim sht0 As Worksheet '存储汇总表Dim cels As Range Worksheets.Add(before:=Worksheets(1)).Name = "90分及以上" '在工作簿新建一个90分及以上的汇总表，该表放在最前面Set sht0 = Worksheets("90分及以上") '为了便于方便，将该工作表缩写为sht0[a1] = "年级": [b1] = "姓名": [c1] = "科目": [d1] = "分数" '：与enter（换行）的作用一样For Each sht In ThisWorkbook.Worksheets '遍历每一个工作表If sht.Name <> sht0.Name Then '只有工作表名非汇总表时执行For Each cels In sht.UsedRangeIf cels.Value >= 90 And VBA.IsNumeric(cels.Value) Then '如果分数>90且为数值型数据时执行（文本格式的值会大于数值，所以要筛选数值型，vba.isnumeric，就想worksheetsfunction.counta 内嵌函数都是先写函数名，再写要汇总的数据）sht0.Range("a1048576").End(xlUp).Offset(1, 0) = sht.Name '最好用range("a1048576").end(xlup)从下到上找最后一个非空值，如果数据只有1行（仅有标题）的话，range("a1").end(xldown)去到了a1048576，无法定位到第2行  班级sht0.Range("a1048576").End(xlUp).Offset(0, 1) = cels.End(xlToLeft) 'a列数据已经update进去了，所以后面只要向右偏移即可  姓名sht0.Range("a1048576").End(xlUp).Offset(0, 2) = cels.End(xlUp) '学科sht0.Range("a1048576").End(xlUp).Offset(0, 3) = cels '成绩'  以下这种写法，如果某学生的姓名为空，则会导致该学生后面的所有姓名都会紊乱（如第二个学生姓名为空，则第三个学生的姓名将会填写在第二个学生姓名，依次类推）                 'sht0.Range("a1048576").End(xlUp).Offset(1, 0).Value = sht.Name'sht0.Range("b1048576").End(xlUp).Offset(1, 0).Value = cels.End(xlToLeft).Value'sht0.Range("c1048576").End(xlUp).Offset(1, 0).Value = cels.End(xlUp).Value'sht0.Range("d1048576").End(xlUp).Offset(1, 0).Value = cels.ValueEnd IfNext celsEnd IfNext sht
End Sub

注意：

找数据的第一个空行，最好使用range(“a1048576”).end(xlup).offset(1,0)
或者range(“a1048675”).end(xlup)(2,1)

------------------------------20220425更新---------------------------

筛选多列同时满足某条件的数据，并汇总到某个工作表中

如图有多个班级的同学成绩，需要将每门课程成绩都>=65分的同学筛选出来

形成一张汇总数据表：

代码如下（使用数组）：

方法1：先定义固定长度的数组arr1（会有很多空值，因为只有部分满足条件），再将arr1中不为空的数据复制给arr2，再将arr2粘贴到数据表中。
注意：如果数组中有空值，则无法复制到数据表！！！

Sub 多表筛选2()
Dim arr
Dim arr1()  '定义一个可变长度的数组，与dim preserve一起使用，必须要()
Dim sht As Worksheet
Dim nr%, nc%, m%Application.DisplayAlerts = False '关闭提醒
For Each sht In ThisWorkbook.Worksheets '如果原始表中有“各科均不低于65分”，则删除If sht.Name = "各科均不低于65分" Thensht.DeleteEnd If
Next sht
Application.DisplayAlerts = True '打开提醒
n = 1 '用于计算存储满足条件的数据的列数，因为要增加一个字段为班级，所以初始设置为1For Each sht In ThisWorkbook.Worksheets '开始循环arr = sht.Range("a1").CurrentRegionarr = Application.Transpose(arr) '把数据转置For nr = 2 To UBound(arr, 2) '从第二列开始循环每一列For nc = 2 To UBound(arr) '从每一列的第二行开始循环If arr(nc, nr) >= 65 Then '如果值>=65则m = m + 1 'm用来存储当列>=65的个数，从而判断是否每一个数据都>=65End IfNext ncIf m = UBound(arr) - 1 Then '如果每列>=65的个数=行数-1（1为姓名所在的行）n = n + 1 '新的数组长度扩1ReDim Preserve arr1(1 To UBound(arr) + 1, 1 To n) '重新定义数组的长度arr1(1, n) = sht.Name '1行n列的名字均为班级For nc = 1 To UBound(arr) '将原表的数组数据赋值到新数组arr1(nc + 1, n) = arr(nc, nr) Next ncEnd Ifm = 0 Next nr
Next shtarr1 = Application.Transpose(arr1) '转置回来
arr = Application.Transpose(arr)
arr1(1, 1) = "班级" '重新定义新数组的第一行第一列
For nc = 1 To UBound(arr, 2) '定义第一行的每一列arr1(1, nc + 1) = arr(1, nc)
Next ncWorksheets.Add(before:=Worksheets(1)).Name = "各科均不低于65分" '建表
Worksheets("各科均不低于65分").Range("a1").Resize(n, UBound(arr, 2) + 1) = arr1 '复制
End Sub

方法2：使用 dim preserve 数组名(新的长度)，注意dim preserve 只能重新定义最后一维数据的长度，所以需要先将数转置，从而扩充列的长度。

Sub 多表筛选()
Dim arr
Dim arr1(1 To 999, 1 To 999) '先固定长度，长度要足够大
Dim arr2 '用来存储没有空值的arr1
Dim sht As Worksheet
Dim nr%, nc%, m%Application.DisplayAlerts = FalseFor Each sht In ThisWorkbook.WorksheetsIf sht.Name = "各科均不低于65分" Thensht.DeleteEnd If
Next shtApplication.DisplayAlerts = True
n = 1For Each sht In ThisWorkbook.Worksheetsarr = sht.Range("a1").CurrentRegionFor nr = 2 To UBound(arr)For nc = 2 To UBound(arr, 2)If arr(nr, nc) >= 65 Thenm = m + 1End IfNext ncIf m = UBound(arr, 2) - 1 Thenn = n + 1arr1(n, 1) = sht.NameFor nc = 1 To UBound(arr, 2)arr1(n, nc + 1) = arr(nr, nc)Next ncEnd Ifm = 0Next nr
Next shtarr1(1, 1) = "班级"
For nc = 1 To UBound(arr, 2)arr1(1, nc + 1) = arr(1, nc)
Next nc
Worksheets.Add(before:=Worksheets(1)).Name = "各科均不低于65分"ReDim arr2(1 To n, 1 To UBound(arr, 2)) '重新定义arr2的长度For nr = 1 To nFor nc = 1 To UBound(arr, 2)arr2(nr, nc) = arr1(nr, nc)Next ncNext nr
Worksheets("各科均不低于65分").Range("a1").Resize(n, UBound(arr, 2)) = arr2
End Sub

VBA学习笔记6：将多个工作表中满足条件的数据汇总到同一个工作表相关推荐

VBA学习笔记5：将同一工作簿的数据按照类别拆分为多个工作簿
VBA学习笔记5:将同一工作簿的数据按照类别拆分为多个工作簿 1.对每行数据按照类别所在列进行循环,判断某类别的工作簿是否存在: 2.如果不存在,则新建工作簿并将该行数据复制粘贴: 3.如果存在则打开 ...
陈表达VBA学习笔记-新建工作表鼠标右键菜单按钮
陈表达VBA学习笔记-新建工作表鼠标右键菜单按钮:新建一个我的菜单按钮设置对应的宏过程名称为 [我的菜单宏] 点击按钮弹窗信息,信息可自定义设置详细代码如下: Sub 新建右键菜单()Dim 菜单 ...
VBA学习笔记2：将工作簿的表格拆分为工作簿
VBA学习笔记2:将工作簿的表格拆分为工作簿 1.判断原有工作簿的sheet是否需要拆分: 2.如需拆分则创建新表: 3.将原sheet复制到新建的工作簿中. 效果如下: 代码执行前,有1个工作簿,需 ...
VBA学习笔记3：合并同一工作簿下的多个表格
VBA学习笔记3:合并同一工作簿下的多个表格 1.建立一个新的汇总表: 2.将其他sheet数据复制到汇总表中. 效果如下: 需要将3个sheet的表的数据汇总起来汇总后的数据: 代码如下: Sub ...
VBA学习笔记1：将同个文件夹中的工作簿汇总为一个工作簿，并建立目录超链接
VBA学习笔记1:将同个文件夹中的工作簿汇总为一个工作簿,并建立目录超链接 1.将文件夹中的xlsx文件名复制到新工作簿: 2.将文件夹中的xlsx数据簿中的sheet复制到新表并重命名: 3.插入超 ...
Excel VBA 学习笔记13：单元格的格式
Excel VBA 学习笔记13:单元格的格式 NumberFormat 属性 (Excel) vba excel 单元格格式设置 Excel VBA 单元格格式 python解决SNIMissing ...
VBA学习笔记（9）--生成点拨（1）
VBA学习笔记(9)--生成点拨(1) 说明(2017.3.26): 1. 还没写完,写到新建文件夹了,下一步新建word,重命名,查找点拨,把点拨复制进去,因为要给点拨编号,应该会很麻烦 1 Pub ...
VBA学习笔记8：单元格的合并与拆分
VBA学习笔记8:单元格的合并与拆分如下图,需要实现1图到2图(单元格合并),或2图到1图(单元格拆分). 1图: 2图: 合并单元格代码如下: Sub 合并单元格()Dim k%, rng As ...
VBA 学习笔记 - 网络请求
VBA 学习笔记 - 网络请求 Microsoft.XMLHTTP MSXML2.serverXMLHTTP.6.0 WinHttp.WinHttpRequest.5.1 参考资料 Microsoft ...
FreeRtos学习笔记（11）查找就绪任务中优先级最高任务原理刨析
FreeRtos学习笔记(11)查找就绪任务中优先级最高任务原理刨析怎么查找就绪任务中优先级最高的? tasks.c中声明了一个全局变量 uxTopReadyPriority,任务从其他状态进入就绪 ...

VBA学习笔记6：将多个工作表中满足条件的数据汇总到同一个工作表

VBA学习笔记6：将多个工作表中满足条件的数据汇总到同一个工作表

脚本如下：

注意：

筛选多列同时满足某条件的数据，并汇总到某个工作表中

代码如下（使用数组）：

VBA学习笔记6：将多个工作表中满足条件的数据汇总到同一个工作表相关推荐

最新文章

热门文章