VBA实现明细表转换为交叉表求和

ruitree

详细数据见附件
试了VBA生成数据透视表再拷贝成普通表的方法。
但是搜了一圈应该能用字典来实现
初学者还不太理解字典的用法，希望高手帮忙，能加上注释就太感谢了，可以帮助进一步学习

又补充了一张图，方便帮忙的人可以直接上代码，不用附件

ruitree

追加一个需求：空值能补充为0

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Application.ScreenUpdating = False
   
6.   Application.DisplayAlerts = False
   
7.   Set d = CreateObject("scripting.dictionary")
   
8.   Set d1 = CreateObject("scripting.dictionary")
   
9.   With Worksheets("sheet1")
   
10.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
11.     arr = .Range("a2:c" & r)
    
12.     n = 1
    
13.     For i = 1 To UBound(arr)
    
14.       If Not d1.exists(arr(i, 1)) Then
    
15.         n = n + 1
    
16.         d1(arr(i, 1)) = n
    
17.       End If
    
18.     Next
    
19.     For i = 1 To UBound(arr)
    
20.       If Not d.exists(arr(i, 2)) Then
    
21.         ReDim brr(1 To d1.Count + 1)
    
22.         brr(1) = arr(i, 2)
    
23.       Else
    
24.         brr = d(arr(i, 2))
    
25.       End If
    
26.       n = d1(arr(i, 1))
    
27.       brr(n) = brr(n) + arr(i, 3)
    
28.       d(arr(i, 2)) = brr
    
29.     Next
    
30.   End With
    
31.   With Worksheets("sheet2")
    
32.     .Cells.Clear
    
33.     .Range("b1").Resize(1, d1.Count) = d1.keys
    
34.     .Range("a2").Resize(d.Count, UBound(brr)) = Application.Transpose(Application.Transpose(d.items))
    
35.   End With
    
36. End Sub
    

复制代码

chxw68

结果在Sheet2中。

ruitree

chxw68 发表于 2019-1-18 16:17
结果在Sheet2中。

对对，就是这个效果，太快了，谢谢，学习中。
如果没有值的位置补充值为0，能否帮忙改一下

chxw68

详见附件。

Tony_Lin

自己查看

1. Sub DicTest()
   
2.   Dim dica As Object, dicb As Object, Arr1, arr2()
   
3.   Set dica = CreateObject("scripting.dictionary")
   
4.   Set dicb = CreateObject("scripting.dictionary")
   
5.   Arr1 = Range("A1").CurrentRegion
   
6.   For x = 2 To UBound(Arr1, 1)
   
7.     If Not dicb.exists(Arr1(x, 1)) Then
   
8.        k = k + 1
   
9.        dicb(Arr1(x, 1)) = k + 1
   
10.     End If
    
11.   Next x
    
12.   
    
13.   ReDim arr2(1 To 1000, 1 To dicb.Count + 1)
    
14.   For y = 2 To UBound(Arr1, 1)
    
15.      If dica.exists(Arr1(y, 2)) Then
    
16.         a = dica(Arr1(y, 2))
    
17.         b = dicb(Arr1(y, 1))
    
18.         arr2(a, b) = arr2(a, b) + Arr1(y, 3)
    
19.      Else
    
20.         m = m + 1
    
21.         dica(Arr1(y, 2)) = m
    
22.         n = dicb(Arr1(y, 1))
    
23.         arr2(m, 1) = Arr1(y, 2)
    
24.         arr2(m, n) = Arr1(y, 3)
    
25.      End If
    
26.   Next
    
27.   
    
28.   Range("N1:R" & Rows.Count) = ""
    
29.   [N1] = "单位"
    
30.   [O1].Resize(1, dicb.Count) = dicb.keys
    
31.   [N2].Resize(dica.Count, dicb.Count + 1) = arr2
    
32. End Sub

复制代码

ruitree

chxw68 发表于 2019-1-18 16:32
详见附件。

好的，感谢
想着如果没回复的话我就最后遍历一遍把空值补充为0的
太效率了
今天的目标是学会字典的用法

ruitree

Tony_Lin 发表于 2019-1-18 16:38
自己查看

谢谢，学习中

ruitree

chxw68 发表于 2019-1-18 16:16

老师，您好！
交叉表求和，一个分类和多个分类求和会了。
但是在前面这个表的基础上再加点变化就不知道在哪循环了，麻烦帮忙看一下。
------------------------------------------
原表最后多一列--数量
一级分类  单位  金额   数量
---------------------------------------
要的结果是：前面交叉表统计不变，在后面再加一列数量的汇总， 数量只按单位汇总就行。
          AC  PE  SF  WU  数量汇总
单位A   -     -     -     -         -
单位B   -     -     -     -         -
单位C   -     -     -     -         -