筛选出重复名单

cejece

想通过对文件名单的筛选，在B列得到名单2。在论坛中找到的代码得出的结果是名单3，哪位大神能帮忙修改一下。

lsc900707

用字典写的：

1. Sub gj23w98()
   
2.     Set d = CreateObject("Scripting.Dictionary")
   
3.     ar = Sheet1.[a1].CurrentRegion
   
4.     ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
   
5.     For i = 2 To UBound(ar)
   
6.         d(ar(i, 1)) = d(ar(i, 1)) + 1
   
7.         If d(ar(i, 1)) > 1 Then
   
8.             m = m + 1
   
9.             d(ar(i, 1)) = m
   
10.             br(m, 1) = ar(i, 1)
    
11.         End If
    
12.     Next
    
13.     If m Then
    
14.         [a1].CurrentRegion.Offset(1).ClearContents
    
15.         [a2].Resize(m, 1) = br
    
16.     End If
    
17. End Sub

复制代码

lsc900707

参考测试附件：

cjc209

Sub tttt()
    Dim brr()
    Set d = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 1)
    For Each tt In arr
        d(tt) = d(tt) + 1
    Next tt
    For Each tt1 In d.keys
        If d(tt1) > 1 Then
            k = k + 1
            brr(k, 1) = tt1
        End If
    Next tt1
    [c2].Resize(UBound(brr), 1) = brr
End Sub

cjc209

或者
Sub tttt()
    Dim brr()
    Set d = CreateObject("scripting.dictionary")
    Set d1 = CreateObject("scripting.dictionary")
    arr = Sheet1.Range("A1").CurrentRegion
    ReDim brr(1 To UBound(arr), 1 To 1)
    For Each tt In arr
        d(tt) = d(tt) + 1
          If d(tt) > 1 Then
            d1(tt) = ""
        End If
    Next tt

    [c2].Resize(d1.Count, 1) = WorksheetFunction.Transpose(d1.keys)
End Sub

dsmch

lsc900707 发表于 2019-1-19 09:22
用字典写的：

第7句>1改为=2较合题意

lsc900707

dsmch 发表于 2019-1-19 13:03
第7句>1改为=2较合题意

感谢提醒。。。。。。

mhps159357

Sub ss()
Dim st$
For i = 2 To 9
If Application.CountIf(Range("a2:a9"), Cells(i, 1)) > 1 Then
k = k + 1
Cells(k, 2) = Cells(i, 1)
End If
Next
End Sub
重复的出来后排序，用IF函数处理一下就可以得到单独的一个值了