求助，大类数值求和，大类里的子类数值也求和，再格式填写

hunter5743

如图，下面是示例的数据。用VB的代码需要把左边的表格转换成右边那样。
如果只是统计各自类别倒是懂一些，生成字典dict，然后大类/子类是关键字，数据为键值再累加，然后输出。
但是那样大类和小类对应就不懂了。

有大神提供点思路吗？

shiruiqiang

请测试，练手

gwjkkkkk

Option Explicit
Sub TEST10()
    Dim ar, br, cr, i&, j&, r&, n&, t#, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Set dic = CreateObject("Scripting.Dictionary")
    ar = [B2].CurrentRegion: t = Timer
   
    For i = 2 To UBound(ar)
        If Not dic.exists(ar(i, 1)) Then
            Set dic(ar(i, 1)) = CreateObject("Scripting.Dictionary")
        End If
        dic(ar(i, 1))(ar(i, 2)) = dic(ar(i, 1))(ar(i, 2)) + ar(i, 3)
    Next i
   
    ReDim br(1 To 10 ^ 3, 1 To 4)
    r = 1
    cr = Split("大类 合计1 子类 合计2")
    For j = 0 To UBound(cr)
        br(r, j + 1) = cr(j)
    Next j
    For Each vKey In dic.keys
        n = 0
        For j = 0 To dic(vKey).Count - 1
             r = r + 1
             br(r, 1) = vKey
             br(r, 3) = dic(vKey).keys()(j)
             br(r, 4) = dic(vKey).items()(j)
             n = n + br(r, 4)
        Next j
        br(r, 2) = n
    Next
   
    Columns("G:J").Clear
    With [G2].Resize(r, 4)
        .Value = br
        br = .Resize(.Rows.Count + 1)
        r = 2
        For i = 2 To UBound(br) - 1
            If br(i + 1, 1) <> br(r, 1) Then
                 For j = 1 To 2
                     Range(.Cells(r, j), .Cells(i, j)).Cells.Merge
                 Next j
                 r = i + 1
            End If
        Next i
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Borders.LineStyle = xlContinuous
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    MsgBox "执行完毕!_用时:  " & Format(Timer - t, "0.00") & "  秒", 64
End Sub

gwjkkkkk

请参考附件。。。

chxw68

参与一下。

cnmlgb9998

用ＰＱ解决 ，不香么？？？？？？？

ykcbf1100

附件供参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf() '//2024、4、30
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     Set d1 = CreateObject("Scripting.Dictionary")
   
4.     With Sheets("Sheet1")
   
5.         r = .Cells(Rows.Count, 2).End(3).Row
   
6.         arr = .[b3].Resize(r - 2, 3)
   
7.         sort2 arr, 1, 1
   
8.         .Cells.UnMerge
   
9.         For i = 1 To UBound(arr)
   
10.             s = arr(i, 1)
    
11.             d1(s) = d1(s) + arr(i, 3)
    
12.             s = arr(i, 1) & "|" & arr(i, 2)
    
13.             d(s) = d(s) + arr(i, 3)
    
14.         Next
    
15.         ReDim brr(1 To d.Count, 1 To 4)
    
16.         For Each k In d.keys
    
17.             m = m + 1
    
18.             brr(m, 1) = Split(k, "|")(0)
    
19.             brr(m, 2) = d1(brr(m, 1))
    
20.             brr(m, 3) = Split(k, "|")(1)
    
21.             brr(m, 4) = d(k)
    
22.         Next
    
23.         .[g3].Resize(m, 4) = brr
    
24.         zr = Array(7, 8)
    
25.         Call hb(3, 9, 7, zr)
    
26.     End With
    
27. End Sub

复制代码

fxl447098457

这报表其实适合数据透视表来实现。

hunter5743

shiruiqiang 发表于 2024-4-30 17:12
请测试，练手

谢谢大神，谢谢大神的方法和设计思路