VBA实现EXCEL透视表功能（汇总+计数）

最新推荐文章于 2024-08-20 17:45:55 发布

阿亮_

最新推荐文章于 2024-08-20 17:45:55 发布

阅读量1.8w

点赞数 11

分类专栏： VBA EXCEL 文章标签：透视表

本文链接：https://blog.csdn.net/dengnihuilaiwpl/article/details/80841533

版权

VBA 同时被 2 个专栏收录

8 篇文章

订阅专栏

EXCEL

2 篇文章

订阅专栏

本文介绍了一个使用VBA编写的透视表生成器，该工具能够根据提供的数据源快速创建Excel透视表，支持多种汇总方式及总计选项。通过定义不同的参数如汇总方式、总计方式等，可以灵活地对数据进行分析。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

Enum 数值
    计数
    求和
End Enum
Enum 总计
    对行列禁用
    对行列启用
    仅对行启用
    仅对列启用
End Enum

Sub 调用()
    y = 透视(Sheets(1).Range("a1:d15"), True, 2, 3, 数值.求和, 总计.对行列启用, Sheets(1).[a21], 1)
    MsgBox "透视" & IIf(y, "成功", "失败")
End Sub

Function 透视(数据源 As Range, 首行为标题 As Boolean, 列标签所在列号 As Integer, 计数求和列所在列号 As Integer, 汇总方式, 总计方式, 结果起始单元格 As Range, ParamArray 行标签所列号()) As Boolean
    On Error GoTo ErrProcess
    sp1 = "|_|"
    Dim re()
    arr = 数据源
    数据起始行 = IIf(首行为标题, 2, 1)
    数据结束行 = UBound(arr)
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    For i = 数据起始行 To 数据结束行
        d(arr(i, 列标签所在列号)) = ""
    Next
    列标签 = d.keys
    d.RemoveAll
    
    For i = 数据起始行 To 数据结束行
        键 = ""
        列数 = 0
        For Each t In 行标签所列号
            If t <> 列标签所在列号 And t <> 计数求和列所在列号 Then
                列数 = 列数 + 1
                键 = 键 & arr(i, t) & sp1 '作为列标签，则不能为行标签
            End If
        Next
        d1(键) = ""
        键 = 键 & arr(i, 列标签所在列号)
        If 汇总方式 = 数值.计数 Then
            d(键) = d(键) + 1
        ElseIf 汇总方式 = 数值.求和 Then
            d(键) = d(键) + arr(i, 计数求和列所在列号) * 1
        End If
    Next
    maxr = d1.Count + 2
    maxc = UBound(列标签) + 列数 + 2
    ReDim re(1 To maxr, 1 To maxc)
    列数 = 0
    For Each t In 行标签所列号
        If t <> 列标签所在列号 And t <> 计数求和列所在列号 Then
            列数 = 列数 + 1
            re(1, 列数) = IIf(首行为标题, arr(1, t), "")
        End If
    Next
    re(1, maxc) = "总计"
    re(maxr, 1) = "总计"
    For i = 0 To UBound(列标签)
        re(1, maxc - 1 - i) = 列标签(UBound(列标签) - i)
    Next
    rekey = d1.keys
    For i = 2 To maxr - 1
        tmp = Split(rekey(i - 2), sp1)
        For j = 0 To UBound(tmp) - 1
            re(i, j + 1) = tmp(j)
        Next
        For j = 0 To UBound(列标签)
            re(i, maxc - 1 - j) = d(rekey(i - 2) & 列标签(UBound(列标签) - j))
            re(maxr, maxc - 1 - j) = re(maxr, maxc - 1 - j) + re(i, maxc - 1 - j)
            re(i, maxc) = re(i, maxc) + re(i, maxc - 1 - j)
        Next
        s = s + re(i, maxc)
    Next
    re(maxr, maxc) = s
    Select Case 总计方式
        Case 总计.对行列禁用: maxr = maxr - 1: maxc = maxc - 1
        Case 总计.对行列启用 '默认
        Case 总计.仅对行启用: maxr = maxr - 1
        Case 总计.仅对列启用: maxc = maxc - 1
    End Select
    结果起始单元格.Resize(maxr, maxc) = re
    结果起始单元格.Resize(maxr, maxc).Interior.Color = 16051688
    透视 = True
    Exit Function
ErrProcess:
    Set d = Nothing
    Set d1 = Nothing
    透视 = False
End Function