明细表用VBA实现分类汇总

zxsea_7426

这个使用字典套字典比较方便，下班时间到了。没空搞了。写个想法。主key: ,二级:key可使用 ,item使用数组:

ykcbf1100

数据已经汇总，小计已经完成，合并单元格现在没做。

ykcbf1100

第一步已经完成

1. Sub ykcbf()  '2024.8.29
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     With Sheets("Sheet1")
   
4.         r = .Cells(Rows.Count, 1).End(3).Row
   
5.         zrr = .[a1].Resize(r, 10)
   
6.         For i = 4 To UBound(zrr)
   
7.             s = zrr(i, 1): ss = zrr(i, 2)
   
8.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
   
9.             If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
   
10.             d(s)(ss)(i) = i
    
11.         Next
    
12.     End With
    
13.     ReDim brr(1 To 10000, 1 To UBound(zrr, 2))
    
14.     b = [{1,2,3,5,10,7,4,6,8,9}]
    
15.     On Error Resume Next
    
16.     With Sheets("Sheet2")
    
17.         .Columns(2).NumberFormatLocal = "@"
    
18.         .UsedRange.Offset(3).Interior.ColorIndex = 0
    
19.         m = 3
    
20.         For Each k In d.keys
    
21.             s1 = 0: s2 = 0: s3 = 0
    
22.             For Each kk In d(k).keys
    
23.                 For Each kkk In d(k)(kk).keys
    
24.                     m = m + 1
    
25.                     For j = 1 To UBound(b)
    
26.                         .Cells(m, j) = zrr(kkk, b(j))
    
27.                     Next
    
28.                     .Cells(m, 7) = .Cells(m, 7) / 10000
    
29.                     .Cells(m, 9) = .Cells(m, 9) / 10000
    
30.                     .Cells(m, 10) = .Cells(m, 10) / 10000
    
31.                     s1 = s1 + .Cells(m, 7)
    
32.                     s2 = s2 + .Cells(m, 9)
    
33.                     s3 = s3 + .Cells(m, 10)
    
34.                 Next
    
35.             Next
    
36.             m = m + 1
    
37.             .Cells(m, 1) = k & " 汇总"
    
38.             .Cells(m, 7) = s1: .Cells(m, 9) = s2: .Cells(m, 10) = s3
    
39.             .Cells(m, 1).Resize(, 10).Interior.ColorIndex = 8
    
40.         Next
    
41.         .[a4].Resize(m - 3, 10).Borders.LineStyle = 1
    
42.     End With
    
43.     Set d = Nothing
    
44.     Set d1 = Nothing
    
45. End Sub
    

复制代码

cindy88sy

ykcbf1100 发表于 2024-8-29 19:29
数据已经汇总，小计已经完成，合并单元格现在没做。

谢谢大佬，我只有这么多的分，能给的全给了。感恩帮助。谢谢。

cindy88sy

zxsea_7426 发表于 2024-8-29 19:25
这个使用字典套字典比较方便，下班时间到了。没空搞了。写个想法。主key:,二级:key可使用,item使用数组:

...

谢谢你的思路，我也思考能否这样，我先试着写看看。我VBA小白中的小白，做得慢，写完给你看。

ykcbf1100

cindy88sy 发表于 2024-8-30 14:30
谢谢大佬，我只有这么多的分，能给的全给了。感恩帮助。谢谢。

把合并单元格加上吧

ykcbf1100

加上合并单元格

1. Sub ykcbf()  '2024.8.30
   
2.     Application.ScreenUpdating = False
   
3.     Application.DisplayAlerts = False
   
4.     Set d = CreateObject("Scripting.Dictionary")
   
5.     With Sheets("Sheet1")
   
6.         r = .Cells(Rows.Count, 1).End(3).Row
   
7.         zrr = .[a1].Resize(r, 10)
   
8.         For i = 4 To UBound(zrr)
   
9.             s = zrr(i, 1): ss = zrr(i, 2)
   
10.             If Not d.exists(s) Then Set d(s) = CreateObject("Scripting.Dictionary")
    
11.             If Not d(s).exists(ss) Then Set d(s)(ss) = CreateObject("Scripting.Dictionary")
    
12.             d(s)(ss)(i) = i
    
13.         Next
    
14.     End With
    
15.     ReDim brr(1 To 10000, 1 To UBound(zrr, 2))
    
16.     b = [{1,2,3,5,10,7,4,6,8,9}]
    
17.     On Error Resume Next
    
18.     With Sheets("Sheet2")
    
19.         .Columns(2).NumberFormatLocal = "@"
    
20.         .UsedRange.Offset(3).Interior.ColorIndex = 0
    
21.         .UsedRange.Offset(3).Clear
    
22.         M = 3
    
23.         For Each k In d.keys
    
24.             s1 = 0: s2 = 0: s3 = 0
    
25.             For Each kk In d(k).keys
    
26.                 For Each kkk In d(k)(kk).keys
    
27.                     M = M + 1
    
28.                     For j = 1 To UBound(b)
    
29.                         .Cells(M, j) = zrr(kkk, b(j))
    
30.                     Next
    
31.                     .Cells(M, 7) = .Cells(M, 7) / 10000
    
32.                     .Cells(M, 9) = .Cells(M, 9) / 10000
    
33.                     .Cells(M, 10) = .Cells(M, 10) / 10000
    
34.                     s1 = s1 + .Cells(M, 7)
    
35.                     s2 = s2 + .Cells(M, 9)
    
36.                     s3 = s3 + .Cells(M, 10)
    
37.                 Next
    
38.             Next
    
39.             M = M + 1
    
40.             .Cells(M, 1) = k & " 汇总"
    
41.             .Cells(M, 7) = s1: .Cells(M, 9) = s2: .Cells(M, 10) = s3
    
42.             .Cells(M, 1).Resize(, 10).Interior.ColorIndex = 8
    
43.         Next
    
44.         Set rng = .[a4].Resize(M - 3, 3)
    
45.         With rng
    
46.             .Borders.LineStyle = 1
    
47.             .HorizontalAlignment = xlCenter
    
48.             .VerticalAlignment = xlCenter
    
49.         End With
    
50.         zr = Array(1)
    
51.         Call hb(4, 10, 1, zr)
    
52.         zr = Array(2, 3)
    
53.         Call hb(4, 10, 2, zr)
    
54.         .[a4].Resize(M - 3, 10).Borders.LineStyle = 1
    
55.     End With
    
56.     Set d = Nothing
    
57.     Set d1 = Nothing
    
58.     Application.ScreenUpdating = True
    
59. End Sub

复制代码

cindy88sy

ykcbf1100 发表于 2024-8-29 18:26
还是有问题的。效果图比数据表多出一列，这一列应该是重复的

不是重复的。比如240210这只债，该债对应好几个购买利率，第一个是该240210债券对应的总剩余面值，一个是　其中某个购买利率对应的剩余面值。

cindy88sy

ykcbf1100 发表于 2024-8-30 14:50
把合并单元格加上吧

哇，好棒，好厉害。我还在研究你的代码逻辑。上面那个问题，不是重复列。剩余面值那列。比如代码240205，第一个是该只债的总剩余面值，第二个是该只债240205下不同购入利率对应的剩余面值。

ykcbf1100

cindy88sy 发表于 2024-8-30 14:56
哇，好棒，好厉害。我还在研究你的代码逻辑。上面那个问题，不是重复列。剩余面值那列。比如代码240205， ...

代码相同就合并，其它列数据可能不同就没合并。