数组字典

一、实现计数求和功能

详情代码如下：

Sub 多列汇总()
    Dim arr, brr, dic
    Dim i&, j&, k&
    arr = Range("a1:c" & Range("a" & Rows.Count).End(xlUp).Row)
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2) + 1)
    Set dic = CreateObject("scripting.dictionary")
    For i = 1 To UBound(arr)
        If dic.exists(arr(i, 1)) Then
            j = dic(arr(i, 1))
            brr(j, 2) = brr(j, 2) + arr(i, 2)
            brr(j, 3) = brr(j, 3) + arr(i, 3)
            brr(j, 4) = brr(j, 4) + 1
        Else
            k = k + 1
            dic(arr(i, 1)) = k
            brr(k, 1) = arr(i, 1)
            brr(k, 2) = arr(i, 2)
            brr(k, 3) = arr(i, 3)
            brr(k, 4) = 1
        End If
    Next i
    brr(1, 4) = "次数"
    Range("e1").Resize(k, UBound(brr, 2)) = brr
    Erase arr
    Erase brr
    Set dic = Nothing
End Sub

二、实现透视表模式汇总

详情代码如下：

Sub 数据透视汇总()
    Dim arr, brr, crr, dic1, dic2
    Dim i&, j&, k&, m&, n&
    Set dic1 = CreateObject("scripting.dictionary")
    Set dic2 = CreateObject("scripting.dictionary")
    arr = Range("a2:c" & Range("a" & Rows.Count).End(xlUp).Row)
    For i = 1 To UBound(arr)
        dic1(arr(i, 2)) = ""
    Next
    ReDim brr(1 To UBound(arr, 1), 1 To dic1.Count + 1)
    ReDim crr(1 To dic1.Count)
    crr = dic1.keys
    For i = 1 To UBound(arr)
        For j = 0 To UBound(crr)
            If arr(i, 2) = crr(j) Then
                n = j + 2
            End If
        Next
        If dic2.exists(arr(i, 1)) Then
            m = dic2(arr(i, 1))
            brr(m, n) = brr(m, n) + arr(i, 3)
        Else
            k = k + 1
            dic2(arr(i, 1)) = k
            brr(k, 1) = arr(i, 1)
            brr(k, n) = arr(i, 3)
        End If
    Next
    Range("g1").Resize(1, UBound(crr) + 1) = crr
    Range("f2").Resize(k, n) = brr
    Erase arr
    Erase brr
    Erase crr
    Set dic1 = Nothing
    Set dic2 = Nothing
End Sub

三、实现逆透视

详情代码如下：

Sub 逆透视()
    Application.ScreenUpdating = False
    Dim arr, brr
    Dim u1, u2, i&, j&, m&, n&
    arr = Range("a1").CurrentRegion
    u1 = UBound(arr, 1) - 1
    u2 = UBound(arr, 2) - 1
    ReDim brr(1 To u1 * u2, 1 To 3)
    '重点：行列遍历,n从零自增u1, m增至u2然后归1
    For i = 1 To u1
        m = 1                   '将m从1至(u2-2)遍历
        For j = i To i + u2 - 1
            n = n + 1           '将n从1到(u1-1)*(1+u2-2)遍历
            m = m + 1
            
            brr(n, 1) = arr(i + 1, 1)
            brr(n, 2) = arr(1, m)
            brr(n, 3) = arr(i + 1, m)
        Next
    Next
    Range("k2").Resize(UBound(brr), 3) = brr
    Erase arr
    Erase brr
    Application.ScreenUpdating = True
End Sub