[已解决]用VBA数组汇总ABC列 最后得到结果FGH列

laoau138

用VBA数组汇总ABC列    最后得到结果FGH列

最佳答案

月排行榜 / 总排行榜

lisachen

2017-6-14 20:37

1. Sub test()
   
2.     Dim arr(), brr()
   
3.     Dim x, y, k, m
   
4.     arr = Range("A1").CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 3)
   
6.     For x = 2 To UBound(arr)
   
7.         For y = 1 To k
   
8.             If arr(x, 1) = brr(y, 1) Then
   
9.                 m = 1
   
10.             brr(y, 2) = arr(x, 2) + brr(y, 2)
    
11.             brr(y, 3) = arr(x, 3) + brr(y, 3)
    
12.             End If
    
13.         Next y
    
14.         If m = 1 Then
    
15.             m = 0
    
16.         Else
    
17.             k = k + 1
    
18.             brr(k, 1) = arr(x, 1)
    
19.             brr(k, 2) = arr(x, 2)
    
20.             brr(k, 3) = arr(x, 3)
    
21.         End If
    
22.     Next x
    
23.     Range("f2").Resize(UBound(arr), 3) = brr
    
24. End Sub
    

复制代码

跳转到最佳答案楼层

laoau138

如何用字典做

lisachen

1. Sub test()
   
2.     Dim arr(), brr()
   
3.     Dim x, y, k, m
   
4.     arr = Range("A1").CurrentRegion
   
5.     ReDim brr(1 To UBound(arr), 1 To 3)
   
6.     For x = 2 To UBound(arr)
   
7.         For y = 1 To k
   
8.             If arr(x, 1) = brr(y, 1) Then
   
9.                 m = 1
   
10.             brr(y, 2) = arr(x, 2) + brr(y, 2)
    
11.             brr(y, 3) = arr(x, 3) + brr(y, 3)
    
12.             End If
    
13.         Next y
    
14.         If m = 1 Then
    
15.             m = 0
    
16.         Else
    
17.             k = k + 1
    
18.             brr(k, 1) = arr(x, 1)
    
19.             brr(k, 2) = arr(x, 2)
    
20.             brr(k, 3) = arr(x, 3)
    
21.         End If
    
22.     Next x
    
23.     Range("f2").Resize(UBound(arr), 3) = brr
    
24. End Sub
    

复制代码

大灰狼1976

字典

1. Sub aaa()
   
2. Dim arr, brr, i&, d As Object, r&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a1].CurrentRegion
   
5. ReDim brr(1 To UBound(arr), 1 To 3)
   
6. For i = 2 To UBound(arr)
   
7.   If Not d.Exists(arr(i, 1)) Then
   
8.     r = r + 1
   
9.     d(arr(i, 1)) = r
   
10.     brr(r, 1) = arr(i, 1)
    
11.   End If
    
12.   brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) + arr(i, 2)
    
13.   brr(d(arr(i, 1)), 3) = brr(d(arr(i, 1)), 3) + arr(i, 3)
    
14. Next i
    
15. [f2].Resize(r, 3) = brr
    
16. End Sub

复制代码