分类汇总

wkxxxr

分类汇总问题，类似之前，分类汇总原始数据列顺序变化，拼凑代码达不到效果，求大佬出手。

wengjl

你的问题不算复杂，就是看了后有点儿懵：是要按甲乙丙丁汇总，还是要按ABCD汇总
只要用IF...ENDIF 和 DO WHILE...LOOP，二者组合即可解决

yes_cn

数据很规范，用透视表就行了。

wkxxxr

yes_cn 发表于 2024-7-11 09:16
数据很规范，用透视表就行了。

这个是可以，但需要正在一起较麻烦，希望一次性汇总在一张表格中。

3190496160

Sub 分类汇总()
Application.ScreenUpdating = False
Dim ar As Variant
Dim i As Long, r As Long, rs As Long
Dim br(), Cr(), dr()
Dim d As Object
Set d = CreateObject("scripting.dictionary")
With ActiveSheet
    r = .Cells(Rows.Count, 1).End(xlUp).Row
    If r < 2 Then MsgBox "数据源为空！": End
    ar = .Range("A1:G" & r)
    ReDim br(1 To UBound(ar), 1 To 3)
    ReDim Cr(1 To UBound(ar), 1 To 3)
    ReDim dr(1 To UBound(ar), 1 To 3)
    For i = 2 To UBound(ar)
        If ar(i, 2) <> "" Then
            t1 = d(ar(i, 2))
            If t1 = "" Then
                k1 = k1 + 1
                d(ar(i, 2)) = k1
                t1 = k1
                br(k1, 1) = ar(i, 2)
            End If
            br(t1, 2) = br(k1, 2) + 1
            br(t1, 3) = br(t1, 3) + ar(i, 6)
        End If
        If ar(i, 3) <> "" Then
            t2 = d(ar(i, 3))
            If t2 = "" Then
                k2 = k2 + 1
                d(ar(i, 3)) = k2
                t2 = k2
                Cr(k2, 1) = ar(i, 3)
            End If
            Cr(t2, 2) = Cr(t2, 2) + 1
            Cr(t2, 3) = Cr(t2, 3) + ar(i, 6)
        End If
        If ar(i, 5) <> "" Then
            t3 = d(ar(i, 5))
            If t3 = "" Then
                k3 = k3 + 1
                d(ar(i, 5)) = k3
                t3 = k3
                dr(k3, 1) = ar(i, 5)
            End If
            dr(t3, 2) = dr(t3, 2) + 1
            dr(t3, 3) = dr(t3, 3) + ar(i, 6)
        End If
    Next i
    .[p1].CurrentRegion.Offset(1) = Empty
    x = Application.Max(k1, k2, k3) + 1
    .[p2].Resize(k1, UBound(br, 2)) = br
    .Cells(x, 16) = "合计"
    .Cells(x, 17) = Application.Sum(Application.Index(br, 0, 2))
    .Cells(x, 18) = Application.Sum(Application.Index(br, 0, 3))
    .[s2].Resize(k2, UBound(Cr, 2)) = Cr
    .Cells(x, 19) = "合计"
    .Cells(x, 20) = Application.Sum(Application.Index(Cr, 0, 2))
    .Cells(x, 21) = Application.Sum(Application.Index(Cr, 0, 3))
    .[v2].Resize(k3, UBound(dr, 2)) = dr
    .Cells(x, 22) = "合计"
    .Cells(x, 23) = Application.Sum(Application.Index(dr, 0, 2))
    .Cells(x, 24) = Application.Sum(Application.Index(dr, 0, 3))
End With
Application.ScreenUpdating = True
MsgBox "ok!"
End Sub

3190496160

项目统计0.rar (11.1 KB, 下载次数: 40)

2024-7-11 10:39 上传

点击文件名下载附件

3190496160

一个简单的数组+字典分类汇总的问题，硬是被你搞得如此复杂，

Qs18

试试.................

Qs18

Sub qs()
Dim arr, i, dic, dic2, dic3
Set dic = CreateObject("scripting.dictionary")
Set dic2 = CreateObject("scripting.dictionary")
Set dic3 = CreateObject("scripting.dictionary")
With Sheet1
arr = Sheet1.Range("a1").CurrentRegion.Value
ReDim brr(1 To UBound(arr), 1 To 9)
For i = 3 To UBound(arr)
    s = arr(i, 2)
   If Not dic.exists(s) Then
    m = m + 1
    brr(m, 1) = s
    dic(s) = m
    brr(m, 2) = 1
    brr(m, 3) = arr(i, 6)
    Else
    r = dic(s)
    brr(r, 2) = brr(r, 2) + 1
    brr(r, 3) = brr(r, 3) + arr(i, 6)
   End If
   ss = arr(i, 3)
   If Not dic2.exists(ss) Then
   mm = mm + 1
   dic2(ss) = mm
   brr(mm, 4) = ss: brr(mm, 5) = 1: brr(mm, 6) = arr(i, 6)
   Else
   rr = dic2(ss)
   brr(rr, 5) = brr(rr, 5) + 1: brr(rr, 6) = brr(rr, 6) + arr(i, 6)
   End If
   s3 = arr(i, 5)
   If Not dic3.exists(s3) Then
    r3 = r3 + 1
    dic3(s3) = r3
    brr(r3, 7) = s3
    brr(r3, 8) = 1: brr(r3, 9) = arr(i, 6)
   Else
    rw = dic3(s3)
    brr(rw, 8) = brr(rw, 8) + 1: brr(rw, 9) = brr(rw, 9) + arr(i, 6)
   End If
Next
a = Array(mm, m, r3)
ma = Application.Max(a)
.Range("p3").Resize(ma, 9) = brr
ReDim b(1 To 1, 1 To 9)
b(1, 1) = "合计": b(1, 4) = "合计": b(1, 7) = "合计"
crr = [{2,3,5,6,8,9}]
For j = 1 To UBound(crr)
    b(1, crr(j)) = Application.WorksheetFunction.Sum(Application.Index(brr, 0, crr(j)))
Next
.Range("p3").Offset(ma).Resize(1, 9) = b
End With
MsgBox "ok!"
End Sub

Qs18

试试.........