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

数值汇总

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

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

Function 数值二维统计表(ByVal arr, term1&, term2&, item&)
    '数值二维统计表(数组，条件1列号，条件2列号，值列号)对数组数据整理汇总，返回一个汇总后含条件的二维数组
    '读取数组为多行3列形式，数据汇总形式为2个条件求和，term1为纵向条件、term2为横向条件
    Dim dict1 As Object, dict2 As Object, result, i&, j&, t1, t2, 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)的字典
        t1 = arr(i, term1): t2 = arr(i, term2)
        If Not dict1.Exists(t1) Then Set dict1(t1) = CreateObject("scripting.dictionary")  '字典嵌套
        dict1(t1)(t2) = dict1(t1)(t2) + arr(i, item): dict2(t2) = ""
    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
    数值二维统计表 = result
End Function

举例

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

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

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

Sub 应收对帐单_数值二维统计表()
    Dim arr, result
    arr = [a2:c323].Value
    result = 数值二维统计表(arr, 1, 2, 3)  '调用函数获取返回数组
    [f1].Resize(UBound(result) + 1, UBound(result, 2) + 1) = result
End Sub

返回结果

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

对以上数值二维统计表函数执行相反操作

Function 数值纵向统计表(ByVal arr)
    '数值纵向统计表(数组)对汇总的二维数组数据进行拆分，返回一个多行3列二维数组(返回数组从1开始计数）
    '返回数组为多行3列形式，纵向条件为第1列、横向条件为第2列、值为第3列，值为空则忽略
    Dim brr, r&, l&, ll&, i&, j&, w&, result
    '表格读取的数组传递后还是从1开始计数（影响遍历）
    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
        数值纵向统计表 = 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
        数值纵向统计表 = result
    End If
End Function

举例

对 Sub 应收对帐单_数值二维统计表() 反向操作

Sub 应收对帐单_数值二维统计表()
    Dim arr, result
    arr = [f1].CurrentRegion.Value
    result = 数值纵向统计表(arr)  '调用函数获取返回数组(返回数组从1开始计数）
    [s1].Resize(1, 3) = Array("箱号", "费用明细", "金额")
    [s2].Resize(UBound(result), UBound(result, 2)) = result
End Sub

返回结果

字符串汇总

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

与方法1类似，将数值求和，改为将字符串通过分隔符合并

Function 字符二维统计表(ByVal arr, term1&, term2&, item&)
    '字符二维统计表(数组，条件1列号，条件2列号，值列号)对数组数据整理汇总，返回一个汇总后含条件的二维数组
    '读取数组为多行3列形式，数据汇按2个条件合并字符串(分隔符连接)，term1为纵向条件、term2为横向条件
    Dim dict1 As Object, dict2 As Object, delimiter$, result, i&, j&, t1$, t2$, s$, k1, k2
    Set dict1 = CreateObject("scripting.dictionary"): delimiter = "，"
    Set dict2 = CreateObject("scripting.dictionary")
    '表格读取的数组传递后还是从1开始计数（影响函数3个参数传参和遍历）
    For i = LBound(arr) To UBound(arr)  'term1为键的字典，嵌套term2为键、值为item列字符串的字典
        t1 = arr(i, term1): t2 = arr(i, term2): s = arr(i, item)
        If Not dict1.Exists(t1) Then Set dict1(t1) = CreateObject("scripting.dictionary")  '字典嵌套
        dict1(t1)(t2) = dict1(t1)(t2) & delimiter & s: dict2(t2) = ""
    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
    '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) = Mid(dict1(result(i, 0))(result(0, j)), 2)
            End If
        Next
    Next
    字符二维统计表 = result
End Function

举例

Sub 字符二维统计表测试()
    Dim arr, result
    arr = [a2:c14]
    result = 字符二维统计表(arr, 1, 2, 3)  '调用函数获取返回数组
    [e1].Resize(UBound(result) + 1, UBound(result, 2) + 1) = result
End Sub