[已解决]EXCEL高手用VBA将相同项合并在一起

vbyou127

EXCEL高手用VBA将相同项合并在一起

最佳答案

月排行榜 / 总排行榜

grf1973

2016-1-7 09:24

1. Sub tt()
   
2.     arr = Range("k10:p" & [k65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 5)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(arr)
   
6.         For j = 1 To UBound(arr, 2)
   
7.             d(arr(i, j)) = ""
   
8.         Next
   
9.         n = 0
   
10.         For Each x In d.keys
    
11.             n = n + 1
    
12.             brr(i, n) = x
    
13.         Next
    
14.         d.RemoveAll
    
15.     Next
    
16.     [q10].Resize(UBound(arr), 5) = brr
    
17. End Sub
    

复制代码

跳转到最佳答案楼层

grf1973

1. Sub tt()
   
2.     arr = Range("k10:p" & [k65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 5)
   
4.     Set d = CreateObject("scripting.dictionary")
   
5.     For i = 1 To UBound(arr)
   
6.         For j = 1 To UBound(arr, 2)
   
7.             d(arr(i, j)) = ""
   
8.         Next
   
9.         n = 0
   
10.         For Each x In d.keys
    
11.             n = n + 1
    
12.             brr(i, n) = x
    
13.         Next
    
14.         d.RemoveAll
    
15.     Next
    
16.     [q10].Resize(UBound(arr), 5) = brr
    
17. End Sub
    

复制代码

sry660

1. Sub 保留不重复项()
   
2. Dim arr, d, i&, j&, iRow&
   
3. [w10:aa10000].ClearContents
   
4. Set d = CreateObject("scripting.dictionary")
   
5. iRow = [k65536].End(xlUp).Row
   
6. For i = 10 To iRow
   
7.     arr = Range("k" & i & ":p" & i)
   
8.     For j = 1 To UBound(arr, 2)
   
9.         d(arr(1, j)) = ""
   
10.     Next
    
11.     Cells(i, "w").Resize(1, d.Count) = d.keys
    
12.     d.RemoveAll
    
13. Next
    
14. End Sub

复制代码

vbyou127

不用字典不是更好吧

grf1973

不用字典。

1. Sub tt()
   
2.     arr = Range("k10:p" & [k65536].End(3).Row)
   
3.     ReDim brr(1 To UBound(arr), 1 To 5)
   
4.     For i = 1 To UBound(arr)
   
5.         x = "": n = 0
   
6.         For j = 1 To UBound(arr, 2)
   
7.             If InStr(x, arr(i, j)) = 0 Then
   
8.                 x = x & arr(i, j)
   
9.                 n = n + 1: brr(i, n) = arr(i, j)
   
10.             End If
    
11.         Next
    
12.     Next
    
13.     [q10].Resize(UBound(arr), 5) = brr
    
14. End Sub

复制代码