如何把一列数据去重？

小女孩

求助.rar (7.13 KB, 下载次数: 8)

2024-1-28 20:05 上传

点击文件名下载附件

，去除重复重新排列问题，具体见附件内。

gwjkkkkk

Option Explicit
Sub TEST5()
    Dim ar, br, i&, dic As Object
   
    Set dic = CreateObject("Scripting.Dictionary")
   
    ar = Range("D3", Cells(Rows.Count, "D").End(xlUp))
    ReDim br(1 To UBound(ar), 0)
    For i = 1 To UBound(ar)
        If Len(ar(i, 1)) Then
           dic(ar(i, 1)) = Empty
        End If
    Next i
    ar = dic.keys
    For i = 0 To UBound(ar)
        br(i * 2 + 1, 0) = ar(i)
    Next i
   
    [f3].Resize(UBound(br)) = br
    Set dic = Nothing
    Beep
End Sub

gwjkkkkk

请参考。。。

ykcbf1100

参与一下。。。

1. Sub ykcbf()  '//2024.1.28
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     r = Me.Cells(Rows.Count, 4).End(3).Row
   
4.     arr = Me.Range("d1:e" & r)
   
5.     For i = 3 To UBound(arr)
   
6.         If arr(i, 1) <> Empty Then
   
7.             b = Split(Replace(arr(i, 1), ",", ""), " ")
   
8.             d.RemoveAll
   
9.             For x = 0 To UBound(b)
   
10.                 d(b(x)) = ""
    
11.             Next
    
12.             st = ""
    
13.             For Each k In d.keys
    
14.                 st = st & " " & k
    
15.             Next
    
16.             arr(i, 2) = Mid(st, 2) & ","
    
17.         End If
    
18.     Next
    
19.     Me.Range("d1:e" & r) = arr
    
20.     MsgBox "OK！"
    
21. End Sub
    

复制代码

ykcbf1100

附件供参考。。。

lushang2018

lushang2018

1. Sub 测试()
   
2.     Dim i%, arr
   
3.     Dim dic As Object, key, keys
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Sheet1.Range("D3:D" & Sheet1.Cells(Rows.Count, "D").End(xlUp).Row)
   
6.     For i = 1 To UBound(arr)
   
7.         If arr(i, 1) <> "" Then
   
8.             key = arr(i, 1)
   
9.             dic(key) = ""
   
10.         End If
    
11.     Next
    
12.     keys = dic.keys
    
13.     For i = 1 To dic.Count
    
14.         Sheet1.Cells(2 * i + 1, "E") = keys(i - 1)
    
15.     Next
    
16. End Sub
    

复制代码