不同于之前写过的 《Excel·VBA统计表生成函数及应用实例》对数据的2个条件汇总生成一个二维横纵统计表，仅对多行多列数据进行简单汇总，生成数据与原始数据格式一致
1，多行多列数据简单汇总
Sub 字典和数组简单汇总数据()
Dim arr, brr, dict, i, j, k
arr = [a1].CurrentRegion.Value
Set dict = CreateObject("scripting.dictionary")
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2)) '返回数组，定义为最大
For i = 2 To UBound(arr)
k = CStr(arr(i, 1)) & CStr(arr(i, 2)) '键
If Not dict.Exists(k) Then '键不存在，新增
j = j + 1 '同时为brr数组序号和字典对应的值
dict(k) = j
brr(j, 1) = arr(i, 1): brr(j, 2) = arr(i, 2) '赋值
brr(j, 3) = arr(i, 3): brr(j, 4) = arr(i, 4)
Else
r = dict(k) '对应brr数组序号
brr(r, 3) = brr(r, 3) + arr(i, 3): brr(r, 4) = brr(r, 4) + arr(i, 4) '累加
End If
Next
[g1].Resize(1, 4) = Array("产品名称", "型号", "数量", "金额")
[g2].Resize(j, UBound(brr, 2)) = brr '仅赋值有写入brr的j行数据
End Sub
举例
左侧数据简单汇总C、D两列数据，得到右侧数据
vba代码也可使用字典嵌套数组的形式汇总，但在输出结果时需要遍历字典item，较本例中直接将数组赋值给工作表，显得较为繁琐；且字典内部键值顺序也可能有所改变，较本例中与原数据顺序一致，也有所不足
2，数据汇总函数化、通用化
Function dictarr_summary(data_arr, col_arr)
'函数定义dictarr_summary(数组，汇总列号数组)对数组数据简单汇总，返回一个汇总后的二维数组
'data_arr为二维数组，col_arr为一维数组，注意汇总列号从1开始计数
Dim dict As Object, key_arr, result, i&, j&, arr, brr, k$, v&, r&, c
Set dict = CreateObject("scripting.dictionary")
'将data_arr排除col_arr中的数据，写入key_arr
ReDim key_arr(1 To UBound(data_arr), 1 To UBound(data_arr, 2))
For j = 1 To UBound(data_arr, 2)
index = Application.Match(j, col_arr, 0)
'不在汇总列号数组中的，index是一个错误值
If TypeName(index) = "Error" Then
For i = 1 To UBound(data_arr)
key_arr(i, j) = data_arr(i, j)
Next
End If
Next
ReDim brr(1 To UBound(data_arr), 1 To UBound(data_arr, 2)) '临时数组，定义为最大
For i = 1 To UBound(data_arr)
arr = Application.index(key_arr, i)
k = CStr(Join(arr, "")) '键
If Not dict.Exists(k) Then '键不存在，新增
v = v + 1 '同时为brr数组序号和字典对应的值
dict(k) = v
For j = 1 To UBound(data_arr, 2)
brr(v, j) = data_arr(i, j)
Next
Else
r = dict(k) '对应brr数组序号
For Each c In col_arr
brr(r, c) = brr(r, c) + data_arr(i, c)
Next
End If
Next
If v = UBound(data_arr) Then
dictarr_summary = brr
Else
ReDim result(1 To v, 1 To UBound(data_arr, 2)) '返回数组，避免无效部分
For i = 1 To v
For j = 1 To UBound(data_arr, 2)
result(i, j) = brr(i, j)
Next
Next
dictarr_summary = result
End If
End Function
match函数
match函数，查找数值在数组中的位置，返回的index从1开始计数，用于判断数组是否包含元素
Application.Match()，未查到会返回一个错误值，但不中断程序
WorksheetFunction.Match()，未查到会报错，中断程序
举例1
对上面举例进行汇总，结果一致
Sub dictarr_summary测试()
'多列汇总
Dim arr, brr, crr, result
arr = [a1].CurrentRegion.Value
brr = [a1].Offset(1, 0).Resize(UBound(arr) - 1, UBound(arr, 2)).Value
crr = Array(3, 4)
result = dictarr_summary(brr, crr)
[g1].Resize(1, UBound(arr, 2)) = Application.index(arr, 1)
[g2].Resize(UBound(result), UBound(result, 2)) = result
'单列汇总
' arr = [a2:c14].Value
' brr = Array(3)
' result = dictarr_summary(arr, brr)
' [g11].Resize(UBound(result), UBound(result, 2)) = result
End Sub
举例2
《excel吧提问》，汇总2列数据
Sub 多列汇总()
Dim arr, brr
arr = [a1].CurrentRegion.Value
brr = Array(3, 5)
result = dictarr_summary(arr, brr)
[g1].Resize(UBound(result), UBound(result, 2)) = result
End Sub
汇总结果
3，工作簿汇总所有工作表数据
except_ws数组参数，支持排除无需汇总的工作表
key_col数组参数，支持以多列关键值列号为字典键汇总数据
最终生成n行*key_col数组元素个数+1列的结果
Sub 工作簿汇总所有工作表数据()
Dim title_row&, end_row&, except_ws, key_col, v_col&, dict As Object, sht As Worksheet
Dim arr, res, temp, i&, j&, k, kk, krr, t&
'--------------------参数填写：except_ws，key_col，v_col，title_row，end_row
except_ws = Array("表1", "表2") '无需汇总的工作表名称，数组
key_col = Array(1, 2) '关键值列号，作为汇总数据的字典键，数组
v_col = 3 '需要汇总数据的列号
title_row = 1: end_row = 0 '表头、表尾行数，不参与汇总数据
delimiter = Chr(28) '分隔符，最好为数据中不存在的字符；仅key_col多个值时需要
ReDim temp(1 To UBound(key_col) - LBound(key_col) + 1): j = UBound(temp) + 1
Set dict = CreateObject("scripting.dictionary"): tm = Timer
With ActiveWorkbook
For Each sht In .Worksheets
y = Application.Match(sht.Name, except_ws, 0)
If TypeName(y) = "Error" Then
arr = sht.UsedRange
For i = title_row + 1 To UBound(arr) - end_row
t = 0
For Each c In key_col
t = t + 1: temp(t) = arr(i, c)
If TypeName(temp(t)) = "Error" Then temp(t) = "" '避免错误值报错
Next
k = Join(temp, delimiter)
If Len(k) > 0 Then dict(k) = dict(k) + arr(i, v_col) '关键值不为空
Next
End If
Next
ReDim res(1 To dict.Count, 1 To j): i = 0 '结果数组
For Each k In dict.keys
krr = Split(k, delimiter): t = 0: i = i + 1: res(i, j) = dict(k)
For Each kk In krr
t = t + 1: res(i, t) = kk
Next
Next
.Worksheets("汇总表").[a1].Resize(UBound(res), UBound(res, 2)) = res
End With
Debug.Print "汇总数据完成，用时：" & Format(Timer - tm, "0.00") '耗时
End Sub
4，字典嵌套字典汇总数据
本函数支持2列条件多列数据形式的汇总，将2列条件作为字典嵌套字典的键，返回的结果是按照第1个键的读入顺序，也可对dictarr_summary()函数结果排序获得一样的效果。（本函数字典嵌套2层字典的方式仅供参考）
Function dict_summary(data_arr, col_key)
'函数定义dict_summary(数组，汇总键列号数组)对数组数据按字典汇总，返回一个汇总后的二维数组
'data_arr为二维数组（从1开始计数），col_key为一维数组，键列号从1开始计数
'注意：键列号需指定顺序，仅支持2个
Dim dict As Object, col_sum, result, i&, j&, x&, y&, n&
If UBound(col_key) - LBound(col_key) <> 1 Then Debug.Print "仅支持2个键": Exit Function
Set dict = CreateObject("scripting.dictionary")
'汇总列号，col_sum数组
ReDim col_sum(1 To UBound(data_arr, 2) - 2)
For i = 1 To UBound(data_arr, 2)
index = Application.Match(i, col_key, 0)
If TypeName(index) = "Error" Then
x = x + 1: col_sum(x) = i
End If
Next
'仅支持字典嵌套1层键字典，然后嵌套1层汇总数据
For i = 1 To UBound(data_arr)
k1 = data_arr(i, col_key(LBound(col_key))): k2 = data_arr(i, col_key(UBound(col_key)))
If Not dict.Exists(k1) Then 'k1键
Set dict(k1) = CreateObject("scripting.dictionary")
End If
If Not dict(k1).Exists(k2) Then 'k2键
Set dict(k1)(k2) = CreateObject("scripting.dictionary")
n = n + 1 '返回数组行数
End If
For j = LBound(col_sum) To UBound(col_sum) '汇总键值
k3 = col_sum(j)
dict(k1)(k2)(k3) = dict(k1)(k2)(k3) + data_arr(i, k3)
Next
Next
ReDim result(1 To n, 1 To UBound(data_arr, 2))
keys1 = dict.keys: x = 0
For i = 0 To dict.count - 1 '遍历字典
keys2 = dict(keys1(i)).keys
For j = 0 To dict(keys1(i)).count - 1
x = x + 1: result(x, 1) = keys1(i): result(x, 2) = keys2(j) '键赋值到数组
values3 = dict(keys1(i))(keys2(j)).Items
For y = 0 To dict(keys1(i))(keys2(j)).count - 1
result(x, y + 3) = values3(y)
Next
Next
Next
dict_summary = result
End Function
举例
Sub dict_summary测试()
Dim arr, brr
arr = [a1].CurrentRegion.Value
brr = Array(2, 1) '键有序
result = dict_summary(arr, brr)
[f1].Resize(UBound(result), UBound(result, 2)) = result
End Sub
汇总结果
2977
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
