Excel·VBA多行多列数据简单汇总

不同于之前写过的 《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，字典嵌套字典汇总数据

本函数支持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

汇总结果