VBA代码汇总，为何数据少时结果正确数据多了结果就不对呢？

kezhiye

VBA代码汇总，为何数据少时结果正确数据多了结果就不对呢？
附件里的汇总代码，测试时数据不多，汇总结果看不出有什么不对，但在实际使用时，数据稍微多了一些，汇总出来的结果就不对了。更加奇怪的是，748行的汇总结果，746行都没问题，但就是有2行不对。
请各位师傅帮忙看看，问题出在哪里，代码要如何修改？不胜感激！
汇总结果错误是何原因.rar (223.22 KB, 下载次数: 14)

2018-1-26 22:24 上传

点击文件名下载附件

kezhiye

朱荣兴 发表于 2018-1-27 00:41
还是应该检查你的工作表数据

出现这种情况是数据的问题不是代码的问题吗？

kezhiye

朱荣兴 发表于 2018-1-27 00:41
还是应该检查你的工作表数据

版主您好！能不能再帮忙看看，数据我也又检查了两遍，没发现什么问题呢

chxw68

1. Sub test()
   
2.   Dim r%, i%
   
3.   Dim arr, brr
   
4.   Dim d As Object
   
5.   Set d = CreateObject("scripting.dictionary")
   
6.   With Worksheets("代码表")
   
7.     r = .Cells(.Rows.Count, 1).End(xlUp).Row
   
8.     arr = .Range("a2:g" & r)
   
9.   End With
   
10.   ReDim brr(1 To UBound(arr), 1 To 13)
    
11.   For i = 1 To UBound(arr)
    
12.     For j = 1 To 3
    
13.       brr(i, j) = arr(i, j)
    
14.     Next
    
15.     brr(i, 4) = arr(i, 6)
    
16.     brr(i, 5) = arr(i, 7)
    
17.     d(brr(i, 1)) = i
    
18.   Next
    
19.   k = 6
    
20.   For Each ws In Worksheets(Array("累计", "本月"))
    
21.     With ws
    
22.       r = .Cells(.Rows.Count, 1).End(xlUp).Row
    
23.       arr = .Range("a2:l" & r)
    
24.       For i = 1 To UBound(arr)
    
25.         If d.exists(arr(i, 2)) Then
    
26.           m = d(arr(i, 2))
    
27.           brr(m, k) = brr(m, k) + arr(i, 10)
    
28.           brr(m, k + 1) = brr(m, k + 1) + arr(i, 12)
    
29.         End If
    
30.       Next
    
31.       k = k + 2
    
32.     End With
    
33.   Next
    
34.   For i = 1 To UBound(brr)
    
35.     brr(i, 10) = brr(i, 5) + brr(i, 6) + brr(i, 8) - brr(i, 7) - brr(i, 9)
    
36.   Next
    
37.   
    
38.   
    
39.   fla = False
    
40.   For i = UBound(brr) - 1 To 1 Step -1
    
41.     bm = brr(i, 1)
    
42.     ReDim crr(4 To 13)
    
43.     j = i + 1
    
44.     Do While brr(j, 1) Like bm & "*"
    
45.       If brr(j, 1) Like bm & "###" Then
    
46.         For k = LBound(crr) To UBound(crr)
    
47.           crr(k) = crr(k) + brr(j, k)
    
48.         Next
    
49.         fla = True
    
50.       End If
    
51.       j = j + 1
    
52.       If j > UBound(brr) Then
    
53.         Exit Do
    
54.       End If
    
55.     Loop
    
56.     If fla Then
    
57.       For k = LBound(crr) To UBound(crr)
    
58.         brr(i, k) = crr(k)
    
59.       Next
    
60.       fla = False
    
61.     End If
    
62.   Next
    
63.   With Worksheets("汇总")
    
64.     .UsedRange.Offset(1, 0).Clear
    
65.     .Range("a2").Resize(UBound(brr), UBound(brr, 2)) = brr
    
66.     r = 1 + UBound(brr)
    
67.     With .Range("a1:m1")
    
68.       .HorizontalAlignment = xlCenter
    
69.     End With
    
70.     With .UsedRange
    
71.       .VerticalAlignment = xlCenter
    
72.     End With
    
73.     With .Range("a2:a" & r)
    
74.       .HorizontalAlignment = xlLeft
    
75.     End With
    
76.     .Range("a1:m" & r).Borders.LineStyle = xlContinuous
    
77.   End With
    
78. End Sub
    

复制代码

chxw68

重新写了一个代码供楼主参考。

kezhiye

朱荣兴 发表于 2018-1-28 09:35
消息收到，研究了你的文件，但是：
1、不明白你汇总的规律和要求，
2、要理清你的代码的思路不是一件容易 ...

版主您好！谢谢您的热情帮助！汇总规律请在我之前发的求助中有描述。http://club.excelhome.net/thread-1331756-1-1.html，麻烦您再帮忙看看这个帖子，看我的问题是否问得清楚明白。谢谢！

kezhiye

chxw68 发表于 2018-1-28 10:22
重新写了一个代码供楼主参考。

chxw68老师您好！首先谢谢您的耐心帮助以及提供的多级汇总代码，您这段代码汇总速度快，结果也准确，但是有两个小问题不知怎么解决：
第一个问题是，最后一行能不能增加一行合计（合计不是所有显示的数的相加，而是不重复数据的相加，比如图片中，1001没有下级，5166784.99的数没有重复，1002有一层下级，1902689.79的数就有一次重复。1123有两层下级，即7位数的1123001是第一层，10位数的1123001001、002和003是第二层下级，那么522500的数就有三次重复了。）
第二个问题是，象目前这样分一下颜色的话，数据核对就更清晰，目前的颜色规律是这样的，有下级的一级即四位代码显一种颜色，有下级的二级即七位代码显一种颜色，有下级的三级即十位代码显一种颜色。没有下级的不显颜色。

kezhiye