Excel·VBA统计表生成函数及应用实例

1，汇总多行多列数据，生成二维横纵统计表

在之前写过的《Excel·VBA考勤打卡记录统计出勤小时》中《统计表生成函数化、通用化》的函数可以汇总多行多列数据，生成二维横纵统计表

Private Function COLLECT(arr, term1, term2, item)
    '函数定义COLLECT(数组，条件1列号，条件2列号，值列号)对数组数据整理汇总，返回一个汇总后含条件的二维数组
    '读取数组为多行3列形式，数据汇总形式为2个条件求和，term1为纵向条件、term2为横向条件
    Dim dict1 As Object, dict2 As Object, result, i, j, k1, k2
    Set dict1 = CreateObject("scripting.dictionary")
    Set dict2 = CreateObject("scripting.dictionary")
    '表格读取的数组传递后还是从1开始计数（影响函数3个参数传参和遍历）
    For i = LBound(arr) To UBound(arr)  'term1为键的字典，嵌套term2为键、值为sum(item)的字典
        If Not dict1.Exists(arr(i, term1)) Then
            Set dict1(arr(i, term1)) = CreateObject("scripting.dictionary")  '字典嵌套
        End If
        dict1(arr(i, term1))(arr(i, term2)) = dict1(arr(i, term1))(arr(i, term2)) + arr(i, item)
        dict2(arr(i, term2)) = ""
    Next
    k1 = dict1.keys
    k2 = dict2.keys
    ReDim result(dict1.count, dict2.count)  '从0开始计数，0即为条件，1开始为数据
    '横纵条件赋值到数组
    For i = 1 To UBound(result)  '纵向
        result(i, 0) = k1(i - 1)
    Next
    For j = 1 To UBound(result, 2)  '横向
        result(0, j) = k2(j - 1)
    Next
    'sum(item)赋值到数组
    For i = 1 To UBound(result)  '纵向
        For j = 1 To UBound(result, 2)  '横向
            If dict1(result(i, 0)).Exists(result(0, j)) Then
                result(i, j) = dict1(result(i, 0))(result(0, j))
            End If
        Next
    Next
    Set dict1 = Nothing  '清除字典，释放内存
    Set dict2 = Nothing
    COLLECT = result
    
End Function

举例

《excel吧提问-竖列数据，快速匹配到表二的横向中》，3列数据中2列条件1列数据进行汇总，返回一个二维横纵统计表。对于此类问题，只需对数据进行整理即可调用该函数处理

数据整理
1，合并单元格取消合并，可使用《Excel·VBA单元格合并、撤销合并》的sub3即可
2，部分单元格有2条数据，可使用《Excel·VBA单元格内容拆分》，分割符为空格
3，将括号内的字符替换为空，再执行分列将费用名称和金额分为2列

以下为统计函数和数据读取、返回的过程

Sub 应收对帐单COLLECT()
    Dim arr, result
    tm = Now()
    arr = [a2:c323].Value
    result = COLLECT(arr, 1, 2, 3)  '调用函数获取返回数组
    [f1].Resize(UBound(result) + 1, UBound(result, 2) + 1) = result
    Debug.Print ("统计完成，累计用时" & Format(Now() - tm, "hh:mm:ss"))  '耗时
End Sub

返回结果

2，汇总的二维横纵统计表，拆分为多行多列数据

对以上COLLECT函数执行相反操作

Private Function RECOLLECT(arr)
    '函数定义RECOLLECT(数组)对汇总的二维数组数据进行拆分，返回一个多行3列二维数组(返回数组从1开始计数）
    'COLLECT函数与RECOLLECT函数操作相反
    '返回数组为多行3列形式，纵向条件为第1列、横向条件为第2列、值为第3列，值为空则忽略
    Dim brr, r, l, ll, i, j, w, result
    r = (UBound(arr) - LBound(arr) + 1) * (UBound(arr, 2) - LBound(arr, 2) + 1) '返回数组最大行数
    ReDim brr(1 To r, 1 To 3)  '临时返回数组，从1开始计数
    l = LBound(arr)
    ll = LBound(arr, 2)
    For i = l + 1 To UBound(arr)  '原二维数组首行首列都是标题
        For j = ll + 1 To UBound(arr, 2)
            If arr(i, j) <> "" Then
                w = w + 1
                brr(w, 1) = arr(i, ll)  '纵向条件为第1列
                brr(w, 2) = arr(l, j)   '横向条件为第2列
                brr(w, 3) = arr(i, j)   '值为第3列
            End If
        Next
    Next
    If r = w Then
        RECOLLECT = brr
    Else
        ReDim result(1 To w, 1 To 3)  '返回数组，避免无效部分
        For i = 1 To w
            result(i, 1) = brr(i, 1): result(i, 2) = brr(i, 2): result(i, 3) = brr(i, 3)
        Next
        RECOLLECT = result
    End If
    
End Function

举例

对 Sub 应收对帐单COLLECT() 反向操作

Sub 应收对帐单RECOLLECT()
    Dim arr, result
    tm = Now()
    arr = [f1].CurrentRegion.Value
    result = RECOLLECT(arr)  '调用函数获取返回数组(返回数组从1开始计数）
    [s1].Resize(1, 3) = Array("箱号", "费用明细", "金额")
    [s2].Resize(UBound(result), UBound(result, 2)) = result
    Debug.Print ("统计完成，累计用时" & Format(Now() - tm, "hh:mm:ss"))  '耗时
End Sub