VBA去重复

wj6433731

根据 'Sheet1' 工作表中的 A 列取唯一值，对 B、C、D 每列单独去重复后使用 “、” 号隔开

wj6433731

目前问题：去重复后合并不全，比如将C列中的停止放到最前面，又可以,

wj6433731

已经解决了， 发错了

liulang0808

liulang0808

附件内容供参考。。。。。。

wj6433731

liulang0808 发表于 2024-12-10 13:17
附件内容供参考。。。。。。

谢谢，老师，我20万行数据，运行特别卡，之前的代码是不卡

wj6433731

wj6433731 发表于 2024-12-10 13:56
谢谢，老师，我20万行数据，运行特别卡，之前的代码是不卡

哦 好的 ，谢谢

liulang0808

这个把字典嵌套取消了。代码调整了，效率会提升一下的

Qs18

1. Sub qs()
   
2. Dim arr, i, dic
   
3. Set dic = CreateObject("scripting.dictionary")
   
4. Set d2 = CreateObject("scripting.dictionary")
   
5. With Sheet1
   
6.     arr = .Range("a1").CurrentRegion.Value
   
7.     ReDim brr(1 To UBound(arr), 1 To 4)
   
8. For i = 2 To UBound(arr)
   
9.     s = arr(i, 1)
   
10.     If Not dic.exists(s) Then
    
11.         m = m + 1
    
12.         dic(s) = m
    
13.         For j = 1 To UBound(arr, 2)
    
14.             brr(m, j) = arr(i, j)
    
15.         Next
    
16.     Else
    
17.         r = dic(s)
    
18.         For x = 2 To UBound(arr, 2)
    
19.             brr(r, x) = brr(r, x) & "、" & arr(i, x)
    
20.             y = Split(brr(r, x), "、")
    
21.             For Each YY In y
    
22.                 If Len(YY) Then
    
23.                 d2(YY) = ""
    
24.                 End If
    
25.             Next
    
26.             brr(r, x) = Join(d2.keys, "、")
    
27.             d2.RemoveAll
    
28.         Next x
    
29.     End If
    
30. Next i
    
31. .Range("g2").Resize(m, 4) = brr
    
32. End With
    
33. End Sub

复制代码

Qs18

试试.......