[已解决]请老师再改改~！！！汇总问题

80013025

汇总后数据显示问题2.rar (13.04 KB, 下载次数: 20)

2014-10-22 08:36 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

dsmch

2014-10-22 08:57

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, s&, h%, l%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("aa5").CurrentRegion
   
5. Const hs As Integer = 38 '打印行数
   
6. ReDim brr(1 To UBound(arr), 1 To 3)
   
7. For i = 2 To UBound(arr)
   
8.     If Not d.exists(arr(i, 1)) Then
   
9.         s = s + 1
   
10.         d(arr(i, 1)) = s
    
11.         brr(s, 1) = arr(i, 1)
    
12.         brr(s, 2) = arr(i, 2)
    
13.         brr(s, 3) = arr(i, 3)
    
14.     Else
    
15.         brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) + arr(i, 2)
    
16.         brr(d(arr(i, 1)), 3) = brr(d(arr(i, 1)), 3) + arr(i, 3)
    
17.     End If
    
18. Next
    
19. n = (s \ hs + 1) * 3
    
20. ReDim crr(1 To hs, 1 To n)
    
21. For i = 1 To s
    
22.     h = (i - 1) Mod hs + 1
    
23.     l = ((i - 1) \ hs) * 3 + 1
    
24.     crr(h, l) = brr(i, 1)
    
25.     crr(h, l + 1) = brr(i, 2)
    
26.     crr(h, l + 2) = brr(i, 3)
    
27. Next
    
28. Range("b8").Resize(hs, n) = crr
    
29. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, s&, h%, l%
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Sheet1.Range("aa5").CurrentRegion
   
5. Const hs As Integer = 38 '打印行数
   
6. ReDim brr(1 To UBound(arr), 1 To 3)
   
7. For i = 2 To UBound(arr)
   
8.     If Not d.exists(arr(i, 1)) Then
   
9.         s = s + 1
   
10.         d(arr(i, 1)) = s
    
11.         brr(s, 1) = arr(i, 1)
    
12.         brr(s, 2) = arr(i, 2)
    
13.         brr(s, 3) = arr(i, 3)
    
14.     Else
    
15.         brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) + arr(i, 2)
    
16.         brr(d(arr(i, 1)), 3) = brr(d(arr(i, 1)), 3) + arr(i, 3)
    
17.     End If
    
18. Next
    
19. n = (s \ hs + 1) * 3
    
20. ReDim crr(1 To hs, 1 To n)
    
21. For i = 1 To s
    
22.     h = (i - 1) Mod hs + 1
    
23.     l = ((i - 1) \ hs) * 3 + 1
    
24.     crr(h, l) = brr(i, 1)
    
25.     crr(h, l + 1) = brr(i, 2)
    
26.     crr(h, l + 2) = brr(i, 3)
    
27. Next
    
28. Range("b8").Resize(hs, n) = crr
    
29. End Sub

复制代码