[已解决]提取取不重复项VBA代码，重复项不再显示，谢谢！

sgzg

求提取某列不重复项，该列重复项不再显示的VBA代码，具体参考附件。谢谢！

最佳答案

月排行榜 / 总排行榜

dsmch

2014-4-26 17:02

1. Sub Macro1()
   
2. Dim arr, brr, d, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. For i = 1 To UBound(arr)
   
6.     If Not d.exists(arr(i, 1)) Then
   
7.         d(arr(i, 1)) = arr(i, 1)
   
8.     Else
   
9.         d(arr(i, 1)) = "@"
   
10.     End If
    
11. Next
    
12. brr = Filter(d.items, "@", False)
    
13. Range("d1").Resize(UBound(brr) + 1) = Application.Transpose(brr)
    
14. End Sub
    

复制代码

跳转到最佳答案楼层

冠军欧洲2010

1. Sub A()
   
2.     Dim K As Integer, I As Integer
   
3.     For K = 2 To 9
   
4.         If Application.CountIf(Range("A2:A9"), Cells(K, 1)) = 1 Then
   
5.             I = I + 1
   
6.             Cells(I, 3) = Cells(K, 1)
   
7.         End If
   
8.     Next
   
9. End Sub
   

复制代码

冥王

A列数据可以为任意个

1. Sub demo()
   
2.     Dim dic As Object
   
3.     Dim r%, i%, arr, k
   
4.     Set dic = CreateObject("scripting.dictionary")
   
5.     arr = Range("A2:A" & Cells(Rows.Count, 1).End(xlUp).Row).Value
   
6.     For i = LBound(arr) To UBound(arr)
   
7.       If Application.CountIf(Range("A:A"), arr(i, 1)) = 1 Then
   
8.         dic(arr(i, 1)) = ""
   
9.       End If
   
10.     Next
    
11.     k = dic.keys
    
12.     Range("D2").Resize(dic.Count, 1) = Application.WorksheetFunction.Transpose(k)
    
13. End Sub

复制代码

冥王

……

su45

两位各有千秋！一个用CountIf判断，一个用字典！

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, d, i&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("a1").CurrentRegion
   
5. For i = 1 To UBound(arr)
   
6.     If Not d.exists(arr(i, 1)) Then
   
7.         d(arr(i, 1)) = arr(i, 1)
   
8.     Else
   
9.         d(arr(i, 1)) = "@"
   
10.     End If
    
11. Next
    
12. brr = Filter(d.items, "@", False)
    
13. Range("d1").Resize(UBound(brr) + 1) = Application.Transpose(brr)
    
14. End Sub
    

复制代码

Zipall

b2输入 =countif(a:a,a2)=1

1. Sub test()
   
2.     Range("a:a").AdvancedFilter xlFilterCopy, Range("b1:b2"), Range("c1"), True
   
3. End Sub
   

复制代码

dsmch

冥王 发表于 2014-4-26 16:46
A列数据可以为任意个

不好意思，看错了，代码中有判断，如果数据量大的话，countif效率不高。

冥王

dsmch 发表于 2014-4-26 17:13
不好意思，看错了，代码中有判断，如果数据量大的话，countif效率不高。

学习dsmch老师的代码      后面那个筛选很精妙啊   不过目光短浅  这种用法没见过  有些不太懂 。。。

sgzg

感谢冥王，还有各位大师，受教了。