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

2023-07-28 05:29| 来源: 网络整理| 查看: 265

需求：现有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.UsedRange If 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.Value End If Next cels End If Next 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分" Then sht.Delete End If Next sht Application.DisplayAlerts = True '打开提醒 n = 1 '用于计算存储满足条件的数据的列数，因为要增加一个字段为班级，所以初始设置为1 For Each sht In ThisWorkbook.Worksheets '开始循环 arr = sht.Range("a1").CurrentRegion arr = 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的个数，从而判断是否每一个数据都>=65 End If Next nc If m = UBound(arr) - 1 Then '如果每列>=65的个数=行数-1（1为姓名所在的行） n = n + 1 '新的数组长度扩1 ReDim 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 nc End If m = 0 Next nr Next sht arr1 = 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 nc Worksheets.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 = False For Each sht In ThisWorkbook.Worksheets If sht.Name = "各科均不低于65分" Then sht.Delete End If Next sht Application.DisplayAlerts = True n = 1 For Each sht In ThisWorkbook.Worksheets arr = sht.Range("a1").CurrentRegion For nr = 2 To UBound(arr) For nc = 2 To UBound(arr, 2) If arr(nr, nc) >= 65 Then m = m + 1 End If Next nc If m = UBound(arr, 2) - 1 Then n = n + 1 arr1(n, 1) = sht.Name For nc = 1 To UBound(arr, 2) arr1(n, nc + 1) = arr(nr, nc) Next nc End If m = 0 Next nr Next sht arr1(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 n For nc = 1 To UBound(arr, 2) arr2(nr, nc) = arr1(nr, nc) Next nc Next nr Worksheets("各科均不低于65分").Range("a1").Resize(n, UBound(arr, 2)) = arr2 End Sub

【本文地址】

公司简介

联系我们