VBA按类别汇总计算的实现方法

f8b1987

最近试着用不同的方法实现类别汇总计算，也就是类似数据透视表的按类别求和、计数。
分享我写的代码，也希望大家提出修正代码，提供更好的代码方法。




我写了几种方式，字数太多，将在二楼及之后楼层贴出代码。
VBA类似透视表求和.zip (888.22 KB, 下载次数: 229)

2020-7-18 12:21 上传

点击文件名下载附件

1.字典去重+数组实现，耗时1秒内。
      次数的key用arr(i, 1) & "|次"，金额的key用arr(i, 1) & "|金"，进行识别；然后将得到的key写入数组crr，循环crr，brr首列取得key，第二列从字典中取得次数，第三列从字典中取得金额。




2.纯数组法，耗时1分钟左右（和我笔记本CPU主频低也有关系）
    循环数组arr第1个元素到当前元素的前一个，判断没有出现过相同的，就把arr元素传递给brr数组中，去重；
内循环brr，当数组arr的元素与brr(y,1)相同，次数累计，金额累加
当数据多时，arr循环次数*brr循环次数会变得非常大，期待大神优化纯数组方法。




3.使用Excel功能去重复+数组运算。耗时19秒左右。
    先从A列复制到D列，调用功能数据-删除重复项，然后将得到的唯一值写入brr。循环arr、内循环brr，判断两者一致时，计算次数及金额。


4.ADO+SQL，耗时约1.5秒。
    楼主不懂SQL，还是特意从论坛Ctrl+C过来的调用代码，参考修改的SQL语句。调用SQL语句进行去重分类统计，然后写入单元格。

f8b1987

1.字典去重+数组实现，耗时1秒内。
      次数的key用arr(i, 1) & "|次"，金额的key用arr(i, 1) & "|金"，进行识别；然后将得到的key写入数组crr，循环crr，brr首列取得key，第二列从字典中取得次数，第三列从字典中取得金额。

1. Sub 字典数组计算()
   
2.         t = Timer
   
3.         Set dic = CreateObject("Scripting.Dictionary")
   
4.         Range("D:F").ClearContents  '清空D:F列内容
   
5.         arr = Range("A1:B25000") '单元格值写入数组
   
6.         ReDim brr(1 To 25001, 1 To 3) '定义数组brr空间，行数比数组arr大1，用于预防没有重复值时brr的合计行超出范围；也可以用Redim brr定义
   
7.         brr(1, 1) = "编号": brr(1, 2) = "次数": brr(1, 3) = "金额"
   
8.         On Error Resume Next
   
9.         For i = 2 To UBound(arr) '循环数组arr
   
10.             dic(arr(i, 1) & "|次") = dic(arr(i, 1) & "|次") + 1   'key添加文字“次”识别，统计同类个数
    
11.             dic(arr(i, 1) & "|金") = dic(arr(i, 1) & "|金") + arr(i, 2)   'key添加文字“金”识别，统计同类金额之和
    
12.     '       dic(arr(i, 1) & "|" & "次") = dic(arr(i, 1) & "|" & "次") + Array(1, arr(i, 2))(0)
    
13.     '       dic(arr(i, 1) & "|" & "次") = dic(arr(i, 1) & "|" & "金") + Array(1, arr(i, 2))(1)
    
14.             mysum = mysum + arr(i, 2)   '累计总金额
    
15.         Next i
    
16.         Erase arr
    
17.         n = 1   '初始值
    
18.         crr = dic.keys  '将key的唯一值放入数组crr
    
19.         For x = 0 To UBound(crr)    '循环数组crr
    
20.                 n = n + 1   '用于确定brr元素的位置，也用于确定数组brr最后有效数据的行位置
    
21.                 If x * 2 > UBound(crr) Then Exit For    '当x*2大于数组crr上限时，退出循环x
    
22.                 brr(n, 1) = Left(crr(x * 2), Len(crr(x * 2)) - 2)   '把key中的“|次"去掉，写入到brr数组第一列
    
23.                 brr(n, 2) = dic(brr(n, 1) & "|" & "次") '把同类别次数写入数组brr
    
24.                 brr(n, 3) = dic(brr(n, 1) & "|" & "金") '把同类别金额之和写入数组brr
    
25.         Next x
    
26.         Erase crr
    
27.         brr(n, 1) = "合计": brr(n, 2) = UBound(arr) - 1: brr(n, 3) = mysum  '合计数写入数组有效行末尾
    
28.         Range("D1").Resize(n, 3) = brr  '数组写入到表格中
    
29.         MsgBox Timer - t
    
30. End Sub

复制代码

f8b1987

2.纯数组法，耗时1分钟左右（和我笔记本CPU主频低也有关系）
    循环数组arr第1个元素到当前元素的前一个，判断没有出现过相同的，就把arr元素传递给brr数组中，去重；
内循环brr，当数组arr的元素与brr(y,1)相同，次数累计，金额累加
当数据多时，arr循环次数*brr循环次数会变得非常大，期待大神优化纯数组方法。

1. Sub 数组法取唯一值()
   
2.         t = Timer
   
3.         Dim arr(), i As Integer, x%, n%, m%
   
4.         Range("D:F").ClearContents  '清空D:F列内容
   
5.         arr = Range("A1:B25000") '单元格值写入数组
   
6.         Dim brr(1 To 25000 + 1, 1 To 3) '定义数组brr空间，行数比数组arr大1，用于预防没有重复值时brr的合计行超出范围；也可以用Redim brr定义
   
7.         brr(1, 1) = "编号": brr(1, 2) = "次数": brr(1, 3) = "金额" '标题文字
   
8.         m = 1   '初始值
   
9.         s = UBound(arr)
   
10.         For i = 2 To s '循环数组arr
    
11.                 For x = 1 To i - 1  '循环数组arr第1个元素到当前元素的上一个
    
12.                         If arr(i, 1) = arr(x, 1) Then
    
13.                             n = n + 1 '如果出现相同，则令n=n+1
    
14.                         End If
    
15.                 Next x
    
16.                 If n = 0 Then   '当n=0，即前面没有出现过相同的
    
17.                         m = m + 1   '数组行增加1
    
18.                         brr(m, 1) = arr(i, 1)   '将arr数组的值赋给brr数组
    
19.                 End If
    
20.                 n = 0   '重置n
    
21.                 For y = 2 To m  '循环brr数组
    
22.                     If arr(i, 1) = brr(y, 1) Then   '当数组arr的元素与brr(y,1)相同
    
23.                             brr(y, 2) = brr(y, 2) + 1   '元素brr(y,2)的计数+1
    
24.                             brr(y, 3) = brr(y, 3) + arr(i, 2)   'brr(y,3)的金额加arr(i,2)
    
25.                     End If
    
26.                 Next y
    
27.                 mysum = mysum + arr(i, 2)   '累加arr数组的金额
    
28.         Next i
    
29.         Erase arr
    
30.         brr(m + 1, 1) = "合计"  'm是最后的有效范围行，加1即后一行，添加文字"合计"
    
31.         brr(m + 1, 2) = s - 1 '写入个数，即数组arr的上限-1
    
32.         brr(m + 1, 3) = mysum   '写入合计金额
    
33.         Range("D1").Resize(m + 1, UBound(brr, 2)) = brr '将数组有效范围m+1行3列写出到单元格中
    
34.         MsgBox Timer - t
    
35. End Sub

复制代码

f8b1987

利用Excel功能去重后，再用数组计算

1. Sub 借助功能去重数组计算()
   
2.     t = Timer
   
3.     Range("D:F").ClearContents  '清空D:F列内容
   
4.     Columns("A:A").Copy
   
5.     Range("D1").Select
   
6.     Sheets("测试").Paste
   
7.     Application.CutCopyMode = False
   
8.     ActiveSheet.Range("$D$1:$D$25000").RemoveDuplicates Columns:=1, Header:=xlNo    '使用excel删除重复项功能去重复
   
9.     arr = Range("A1:B25000") '单元格值写入数组
   
10.     brr = Range("D1:F802") '单元格值写入数组
    
11.     For i = 2 To UBound(arr)
    
12.             For x = 2 To UBound(brr)
    
13.                     If arr(i, 1) = brr(x, 1) Then   '当arr与brr的编号一致时
    
14.                             brr(x, 2) = brr(x, 2) + 1   '统计次数
    
15.                             brr(x, 3) = brr(x, 3) + arr(i, 2)   '累加金额
    
16.                     End If
    
17.             Next x
    
18.     Next i
    
19.     Range("D1").Resize(UBound(brr), UBound(brr, 2)) = brr '将数组写出到单元格中
    
20.     MsgBox Timer - t
    
21. End Sub

复制代码

f8b1987

SQL方法

1. Sub Test4()
   
2.     t = Timer
   
3.     Dim Conn As Object, Rst As Object
   
4.     Dim strConn As String, strSQL As String
   
5.     Dim i As Integer, PathStr As String
   
6.     Set Conn = CreateObject("ADODB.Connection")
   
7.     Set Rst = CreateObject("ADODB.Recordset")
   
8.     PathStr = ThisWorkbook.FullName   '设置工作簿的完整路径和名称
   
9.     Select Case Application.Version * 1    '设置连接字符串,根据版本创建连接
   
10.     Case Is <= 11
    
11.         strConn = "Provider=Microsoft.Jet.Oledb.4.0;Extended Properties=excel 8.0;Data source=" & PathStr
    
12.     Case Is >= 12
    
13.         strConn = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & PathStr & ";Extended Properties=""Excel 12.0;HDR=YES"";"""
    
14.     End Select
    
15.     '设置SQL查询语句
    
16.     strSQL = "select 编号,count(编号),sum(金额) from [测试$] group by 编号" 'count统计个数，sum求和,group by 编号(表示按编号聚合统计，也就是编号会去重作为类似透视表的行标签）
    
17.     Conn.Open strConn    '打开数据库链接
    
18.     Set Rst = Conn.Execute(strSQL)    '执行查询，并将结果输出到记录集对象
    
19.     Cells(1, 4) = "编号": Cells(1, 5) = "次数": Cells(1, 6) = "金额"
    
20.     Range("D2").CopyFromRecordset Rst   '将查询结果写出到表格
    
21.     Rst.Close    '关闭数据库连接
    
22.     Conn.Close
    
23.     Set Conn = Nothing
    
24.     Set Rst = Nothing
    
25.     MsgBox Timer - t
    
26. End Sub

复制代码

f8b1987

统计班级人数及平均分.zip (13.66 KB, 下载次数: 64)

2020-7-20 15:10 上传

点击文件名下载附件

没什么大神来补充么？


附上论坛常见的问题帖子
http://club.excelhome.net/thread-1546943-1-1.html

1. Sub 字典数组计算()
   
2.         t = Timer
   
3.         Set dic = CreateObject("Scripting.Dictionary")
   
4.         Range("I6:K1000").ClearContents  '清空D:F列内容
   
5.         mrow = Range("A65536").End(3).Row
   
6.         arr = Range("A2:E" & mrow) '单元格值写入数组
   
7.         ReDim brr(1 To mrow + 1, 1 To 3) '定义数组brr空间，行数比数组arr大1，用于预防没有重复值时brr的合计行超出范围；也可以用Redim brr定义
   
8.         brr(1, 1) = "班级": brr(1, 2) = "人数": brr(1, 3) = "平均分"
   
9.         On Error Resume Next
   
10.         For i = 2 To UBound(arr) '循环数组arr
    
11.             dic(Left(arr(i, 1), 2) & "|次") = dic(Left(arr(i, 1), 2) & "|次") + 1  'key添加文字“次”识别，统计同类个数
    
12.             dic(Left(arr(i, 1), 2) & "|均") = dic(Left(arr(i, 1), 2) & "|均") + arr(i, 5)   'key添加文字“均”识别，统计同班级成绩之和
    
13.             myc = myc + 1 '累计总次数
    
14.             mys = mys + arr(i, 5) '累计总成绩
    
15.         Next i
    
16.         Erase arr
    
17.         n = 1   '初始值
    
18.         crr = dic.keys  '将key的唯一值放入数组crr
    
19.         For x = 0 To UBound(crr)    '循环数组crr
    
20.                 n = n + 1   '用于确定brr元素的位置，也用于确定数组brr最后有效数据的行位置
    
21.                 If x * 2 > UBound(crr) Then Exit For    '当x*2大于数组crr上限时，退出循环x
    
22.                 brr(n, 1) = Left(crr(x * 2), Len(crr(x * 2)) - 2)   '把key中的“|次"去掉，写入到brr数组第一列
    
23.                 brr(n, 2) = dic(brr(n, 1) & "|次") '把同类别次数写入数组brr
    
24.                 brr(n, 3) = Round(dic(brr(n, 1) & "|均") / brr(n, 2), 2) '把同类别成绩之和写入数组brr/次数
    
25.         Next x
    
26.         Erase crr
    
27.         brr(n, 1) = "合计": brr(n, 2) = myc: brr(n, 3) = Round(mys / myc, 2) '合计数写入数组有效行末尾
    
28.         Range("I5").Resize(n, 3) = brr  '数组写入到表格中
    
29.         MsgBox Timer - t
    
30. End Sub
    

复制代码

excelhome9819

f8b1987 发表于 2020-7-18 12:22
1.字典去重+数组实现，耗时1秒内。
      次数的key用arr(i, 1) & "|次"，金额的key用arr(i, 1) & "|金"， ...

老师，我刚才阅读您的方法，非常优秀。我这里有个汇总，我想采用字典数组法。和您的不同的时，我希望汇总在另外一个工作表里面。我把文件发来，在该帖子的后面。请您指导。谢谢！

excelhome9819

数据源在“原始数据”工作表中，汇总后的结果在“汇总”工作表内
原始数据：

希望的汇总结果：

再次感谢您！

opel-wong

针对一楼的附件，试试这个：

1. Public Sub 字典法提取数据()
   
2.     Dim T1 As Date: T1 = Timer
   
3.     Dim d As Object, arr, k, s As String, i As Long
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     Range("D:F").ClearContents
   
6.     arr = [a1].CurrentRegion.Value
   
7.     For i = 2 To UBound(arr)
   
8.         s = arr(i, 1)
   
9.         If Not d.exists(s) Then
   
10.             d(s) = Array(arr(i, 1), 1, arr(i, 2))
    
11.         Else
    
12.             k = d(s)
    
13.             k(1) = k(1) + 1
    
14.             k(2) = k(2) + arr(i, 2)
    
15.             d(s) = k
    
16.         End If
    
17.     Next
    
18.     [E1:G1].Value = Array("编号", "次数", "金额")
    
19.     [E2].Resize(d.Count, 3) = Application.Rept(d.items, 1)
    
20.     Set d = Nothing
    
21.     MsgBox "提取完成，用时约：" & Format(Timer - T1, "0.00") & " 秒！"
    
22. End Sub

复制代码

excelhome9819

opel-wong 发表于 2021-1-24 17:20
针对一楼的附件，试试这个：

老师，谢谢你的指导，我看到其中的代码[E1:G1].Value = Array("编号", "次数", "金额")，和我期望的数据字段不符合