通过字典和数组进行分类汇总表格数据

Sub 分类汇总求和()
Dim arr
Sheets("分类汇总").Select
Range("a2:h30000").ClearContents
h = Sheets("汇总").Cells(65535, 1).End(xlUp).Row
arr = Sheets("汇总").Range("a2:g" & h)
ReDim brr(1 To UBound(arr), 1 To UBound(arr, 2))
Set mydic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(arr, 1)
    k = arr(i, 1) & "丨" & arr(i, 2) & "丨" & arr(i, 3) & "丨" & arr(i, 5) & "丨" & arr(i, 6)
    If Not mydic.exists(k) Then
        j = j + 1
        mydic(k) = j
        brr(j, 1) = arr(i, 1)
        brr(j, 2) = arr(i, 2)
        brr(j, 3) = arr(i, 3)
        brr(j, 4) = arr(i, 5)
        brr(j, 5) = arr(i, 6)
        brr(j, 6) = IIf(arr(i, 7) = "系统", brr(j, 6) + arr(i, 4), brr(j, 6))
        brr(j, 7) = IIf(arr(i, 7) = "实际", brr(j, 7) + arr(i, 4), brr(j, 7))
    Else
        r = mydic(k)
        brr(r, 6) = IIf(arr(i, 7) = "系统", brr(r, 6) + arr(i, 4), brr(r, 6))
        brr(r, 7) = IIf(arr(i, 7) = "实际", brr(r, 7) + arr(i, 4), brr(r, 7))
    End If
Next
Set mydic = Nothing
Cells(2, 1).Resize(j, UBound(brr, 2)) = brr

For i = 2 To Cells(65535, 1).End(xlUp).Row
    Cells(i, 8) = Cells(i, 7) - Cells(i, 6)
Next
End Sub