[已解决]用VBA字典数组汇总2列多列

laoau138

用VBA字典数组汇总2列多列

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-6-19 11:08

1. Sub aaa()
   
2. Dim arr, i&, brr, r&, d As Object
   
3. arr = [a1].CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To 2)
   
5. Set d = CreateObject("scripting.dictionary")
   
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. Next i
    
14. [e2].Resize(r, 2) = brr
    
15. End Sub

复制代码

跳转到最佳答案楼层

lisachen

1. Sub test()
   
2.     Dim arr(), brr(1 To 1000, 1 To 2)
   
3.     Dim x, k, h
   
4.     Dim d
   
5.     Set d = CreateObject("scripting.dictionary")
   
6.     arr = Range("A1").CurrentRegion
   
7.     For x = 2 To UBound(arr)
   
8.         If d.Exists(arr(x, 1)) Then
   
9.             h = d(arr(x, 1))
   
10.             brr(h, 2) = arr(x, 2) + brr(h, 2)
    
11.         Else
    
12.             k = k + 1
    
13.             d(arr(x, 1)) = k
    
14.             brr(k, 1) = arr(x, 1)
    
15.             brr(k, 2) = arr(x, 2)
    
16.         End If
    
17.     Next x
    
18.     Range("e2").Resize(UBound(arr), 2) = brr
    
19. End Sub

复制代码

大灰狼1976

1. Sub aaa()
   
2. Dim arr, i&, brr, r&, d As Object
   
3. arr = [a1].CurrentRegion
   
4. ReDim brr(1 To UBound(arr), 1 To 2)
   
5. Set d = CreateObject("scripting.dictionary")
   
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. Next i
    
14. [e2].Resize(r, 2) = brr
    
15. End Sub

复制代码

laoau138

大灰狼1976 发表于 2017-6-19 11:08

你的代码更精简一点