benzer olmayan kayıtları süzmek, aynı olan tüm satırları silmek

[gezgin-49]

Sayın üstadlarım

aşağıdaki kodlarla A hücresindeki birden fazla aynı kayıt varsa birini bırakıp diğerlerini siliyor,

Sub BenzerSil()
For i = [A65536].End(3).Row To 2 Step -1
If Cells(i, "A") = Cells(i - 1, "A") Then Rows(i).Delete
Next i
End Sub

Ama benim istediğim

A hücresinde benzer olan tüm kayıtları silsin, kalan birini de bırakmasın
farklı olan kayıtlar tek kalsın istiyorum. bu konuda yardımlarınızı bekliyorum.

 

[veyselemre]

Sub benzersizlerKalsin()
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            If Application.CountIf(Columns(1), Cells(i, 1).Value) > 1 Then Cells(i, 2).Value = "*"
        Next i
        For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
            If Cells(i, 2).Value = "*" Then Rows(i).Delete
        Next i
End Sub

Sub benzersizlerKalsin2()
    With CreateObject("Scripting.Dictionary")
        For i = 2 To Cells(Rows.Count, 1).End(3).Row
            key = Cells(i, 1).Value
            .Item(key) = .Item(key) + 1
        Next i
        For i = Cells(Rows.Count, 1).End(3).Row To 2 Step -1
            If .Item(Cells(i, 1).Value) > 1 Then Rows(i).Delete
        Next i
    End With
End Sub

 

[gezgin-49]

Harikasın sayın Veyselemre Allah razı olsun, tam istediğim gibi
eline emeğine sağlık

 

[hamitcan]

Ben de bir tane ekleyeyim.

    Sub Sil()
        Dim arr()
        For i = 2 To [a65536].End(3).Row
            s = WorksheetFunction.CountIf([a:a], Cells(i, 1))
            If s > 1 Then
                c = c + 1
                ReDim Preserve arr(0 To c)
                arr(c) = i
            End If
        Next
        For j = UBound(arr) To 1 Step -1
            Rows(arr(j)).Delete
        Next
    End Sub

 

[gezgin-49]

Allah razı olsun üstadım Hamitcan, iyiki varsınız