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

76 篇文章 27 订阅
这篇博客介绍了如何使用VBA在Excel中处理多行多列数据,包括数值和字符串的汇总。首先,`数值二维统计表`函数用于汇总数据,生成二维横纵统计表,适用于考勤打卡记录统计和费用汇总等场景。接着,`数值纵向统计表`函数将二维横纵统计表拆分为多行多列数据。最后,`字符二维统计表`函数用于按指定条件合并字符串,同样生成二维统计表。这些函数方便地实现了数据整理和汇总,提高了工作效率。
摘要由CSDN通过智能技术生成

数值汇总

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

在这里插入图片描述

评论
添加红包

请填写红包祝福语或标题

红包个数最小为10个

红包金额最低5元

当前余额3.43前往充值 >
需支付:10.00
成就一亿技术人!
领取后你会自动成为博主和红包主的粉丝 规则
hope_wisdom
发出的红包

打赏作者

薛定谔_51

你的鼓励将是我创作的最大动力

¥1 ¥2 ¥4 ¥6 ¥10 ¥20
扫码支付:¥1
获取中
扫码支付

您的余额不足,请更换扫码支付或充值

打赏作者

实付
使用余额支付
点击重新获取
扫码支付
钱包余额 0

抵扣说明:

1.余额是钱包充值的虚拟货币,按照1:1的比例进行支付金额的抵扣。
2.余额无法直接购买下载,可以购买VIP、付费专栏及课程。

余额充值