会计科目逐级汇总

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim flg As Boolean
   
5.   Dim hj(6 To 9) As Double
   
6.   tt = Timer
   
7.   flg = False
   
8.   For i = 6 To 9
   
9.     hj(i) = 0
   
10.   Next
    
11.   With Worksheets("sheet1")
    
12.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
13.     .Range("a5:i" & r).Interior.ColorIndex = 0
    
14.     arr = .Range("a5:i" & r)
    
15.     For i = UBound(arr) - 1 To 1 Step -1
    
16.       bm = arr(i, 1)
    
17.       j = i + 1
    
18.       Do While arr(j, 1) Like bm & "*"
    
19.         If arr(j, 1) Like bm & "??" Or arr(j, 1) Like bm & "???" Then
    
20.           For k = 6 To 9
    
21.             hj(k) = hj(k) + arr(j, k)
    
22.           Next
    
23.           flg = True
    
24.         End If
    
25.         j = j + 1
    
26.       Loop
    
27.       If flg Then
    
28.         For k = 6 To 9
    
29.           arr(i, k) = hj(k)
    
30.           hj(k) = 0
    
31.         Next
    
32.         .Cells(i + 4, 6).Resize(1, 4).Interior.ColorIndex = 4
    
33.         flg = False
    
34.       End If
    
35.     Next
    
36.     .Range("a5").Resize(UBound(arr), UBound(arr, 2)) = arr
    
37.   End With
    
38.   MsgBox "数据汇总完毕，共用时" & Timer - tt & "秒"
    
39. End Sub
    

复制代码

chxw68

详见附件。

laughingsun

chxw68 发表于 2021-5-8 07:55
详见附件。

老师辛苦了，完全达到目的，而且运行速度非常快！非常感谢！

laughingsun

fanyoulin 发表于 2021-5-7 12:43
刚才忘记上传附件了，补上；

老师辛苦了，你这是另一种思路，值得学习！谢谢！

yjh_27

laughingsun 发表于 2021-5-8 09:06
老师辛苦了，完全达到目的，而且运行速度非常快！非常感谢！

a列按长度识别级：长度4=1级，长度6=2级，长度>6  =3级

你的391、392行之间的级与其他规律不同，按长度识别则会跳级（391行1级、392行3级）
你确定这之间原始数据就是这样的？

准提部林

<准提部林>會計科目逐級匯總:
一個循環+字典...一次填色
Xl0000456.rar (69.87 KB, 下载次数: 75)

2021-5-8 11:05 上传

点击文件名下载附件

laughingsun

yjh_27 发表于 2021-5-8 11:03
a列按长度识别级：长度4=1级，长度6=2级，长度>6  =3级

你的391、392行之间的级与其他规律不同，按长 ...

这几天有点忙没有上来！我也发现了这个问题，对代码修改了一下，正在使用中！谢谢老师提醒！

laughingsun

准提部林 发表于 2021-5-8 11:06
會計科目逐級匯總:
一個循環+字典...一次填色

这几天忙没有上来看！老师的这个代码更通用，谢谢老师，辛苦了！