[已解决]VBA用两种方法把AB列省市合并起来

laoau138

VBA用两种方法把AB列省市合并起来

最佳答案

月排行榜 / 总排行榜

大灰狼1976

2017-10-28 09:48

1. Sub dic()
   
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 2)
   
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.     brr(r, 2) = arr(i, 2)
    
12.   Else
    
13.     brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) & "," & arr(i, 2)
    
14.   End If
    
15. Next i
    
16. [d2].Resize(r, 2) = brr
    
17. End Sub
    
18. 
    
19. Private Sub ary()
    
20. Dim arr, brr, i&, k&, r&
    
21. arr = [a1].CurrentRegion
    
22. ReDim brr(1 To UBound(arr), 1 To 2)
    
23. brr(1, 1) = arr(2, 1): brr(1, 2) = arr(2, 2)
    
24. r = 1
    
25. For i = 3 To UBound(arr)
    
26.   For k = 1 To r
    
27.     If arr(i, 1) = brr(k, 1) Then
    
28.       brr(k, 2) = brr(k, 2) & "," & arr(i, 2)
    
29.       Exit For
    
30.     End If
    
31.   Next k
    
32.   If k > r Then
    
33.     r = r + 1
    
34.     brr(r, 1) = arr(i, 1)
    
35.     brr(r, 2) = arr(i, 2)
    
36.   End If
    
37. Next i
    
38. [d2].Resize(r, 2) = brr
    
39. End Sub

复制代码

跳转到最佳答案楼层

大灰狼1976

1. Sub dic()
   
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 2)
   
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.     brr(r, 2) = arr(i, 2)
    
12.   Else
    
13.     brr(d(arr(i, 1)), 2) = brr(d(arr(i, 1)), 2) & "," & arr(i, 2)
    
14.   End If
    
15. Next i
    
16. [d2].Resize(r, 2) = brr
    
17. End Sub
    
18. 
    
19. Private Sub ary()
    
20. Dim arr, brr, i&, k&, r&
    
21. arr = [a1].CurrentRegion
    
22. ReDim brr(1 To UBound(arr), 1 To 2)
    
23. brr(1, 1) = arr(2, 1): brr(1, 2) = arr(2, 2)
    
24. r = 1
    
25. For i = 3 To UBound(arr)
    
26.   For k = 1 To r
    
27.     If arr(i, 1) = brr(k, 1) Then
    
28.       brr(k, 2) = brr(k, 2) & "," & arr(i, 2)
    
29.       Exit For
    
30.     End If
    
31.   Next k
    
32.   If k > r Then
    
33.     r = r + 1
    
34.     brr(r, 1) = arr(i, 1)
    
35.     brr(r, 2) = arr(i, 2)
    
36.   End If
    
37. Next i
    
38. [d2].Resize(r, 2) = brr
    
39. End Sub

复制代码

laoau138

大灰狼1976 发表于 2017-10-28 09:48

VBA用数组实现手动输入条件  然后自动筛选


http://www.excelpx.com/thread-434648-1-1.html