[已解决]用VBA先去重 再计算次数

laoau138

用VBA先去重 再计算次数

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-4-27 15:58

1. Sub aaa()
   
2. Dim arr, ar, d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a2].CurrentRegion
   
5. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 2)
   
6. For Each ar In arr
   
7.   If Not d.exists(ar) Then
   
8.     r = r + 1
   
9.     d(ar) = r
   
10.     brr(r, 1) = ar
    
11.   End If
    
12.   brr(d(ar), 2) = brr(d(ar), 2) + 1
    
13. Next
    
14. [e2].Resize(r, 2) = brr
    
15. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub aaa()
   
2. Dim arr, ar, d As Object
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = [a2].CurrentRegion
   
5. ReDim brr(1 To UBound(arr) * UBound(arr, 2), 1 To 2)
   
6. For Each ar In arr
   
7.   If Not d.exists(ar) Then
   
8.     r = r + 1
   
9.     d(ar) = r
   
10.     brr(r, 1) = ar
    
11.   End If
    
12.   brr(d(ar), 2) = brr(d(ar), 2) + 1
    
13. Next
    
14. [e2].Resize(r, 2) = brr
    
15. End Sub

复制代码

france723

虽然没有字典法简单, 提供一个数组法的思路

1. Sub aaa()
   
2. Dim y, ar, x, m, n&, br, cr, p, b As Boolean
   
3. ar = [a2].CurrentRegion
   
4. ReDim cr(1 To 1)
   
5. ReDim br(1 To 1)
   
6. i = 0
   
7. For Each x In ar
   
8. n = 0
   
9.     For Each m In ar
   
10.         If x = m Then
    
11.             n = n + 1
    
12.         End If
    
13.     Next m
    
14.     If n > 1 Then
    
15.         For Each p In br
    
16.             If x = p Then
    
17.             b = True
    
18.             End If
    
19.         Next p
    
20.         If b = False Then
    
21.             i = i + 1
    
22.             ReDim Preserve br(1 To i)
    
23.             br(i) = x
    
24.             ReDim Preserve cr(1 To i)
    
25.             cr(i) = n
    
26.         End If
    
27.     End If
    
28. b = False
    
29. Next x
    
30. Range("e2").Resize(UBound(br), 1) = Application.Transpose(br)
    
31. Range("f2").Resize(UBound(cr), 1) = Application.Transpose(cr)
    
32. 
    
33. End Sub

复制代码