Excel·VBA多行多列数据简单汇总 |
您所在的位置：网站首页 › excel嵌套汇总 › Excel·VBA多行多列数据简单汇总 |
Excel·VBA多行多列数据简单汇总
|
目录
1，多行多列数据简单汇总举例
2，数据汇总函数化、通用化match函数举例1举例2
3，字典嵌套字典汇总数据举例
不同于之前写过的
《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两列数据，得到右侧数据
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汇总结果
本函数支持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汇总结果 |
vba代码也可使用字典嵌套数组的形式汇总，但在输出结果时需要遍历字典item，较本例中直接将数组赋值给工作表，显得较为繁琐；且字典内部键值顺序也可能有所改变，较本例中与原数据顺序一致，也有所不足
【本文地址】
今日新闻 |
推荐新闻 |