3 Kritere Göre Mükerrer Kayıtları Silmek

[alptun20]

Elimde çok uzun bir liste var ve aynı şahsın 5-6 kaydı var. Adı-Soyadı-Baba Adı sütunlarını baz alarak listeyi benzersiz hale getirip mükerrer kayıtları silmek istiyorum. Ekli Listede sarı renkli sütunları silecek bir koda ihtiyacım var. Herkese kolay gelsin iyi çalışmalar.

 

[Murat OSMA]

Şu kodları bir deneyiniz;

Sub Emre()
    Dim con As Object, rs As Object
    Dim sorgu As String, dosya As String
    Set con = CreateObject("adodb.connection")
    Set rs = CreateObject("adodb.recordSet")
        dosya = ThisWorkbook.FullName
        con.Open "Provider=Microsoft.jet.oledb.4.0;Data Source=" _
        & dosya & ";Extended Properties=""Excel 8.0;hdr=yes"""
        sorgu = "Select distinct [Adı], [Soyadı], [Baba Adı] FROM [Sayfa1$] "
        rs.Open sorgu, con, 1, 1
        Range("E2").CopyFromRecordset rs
    rs.Close: con.Close
    Set con = Nothing: Set rs = Nothing
    dosya = vbNullString: sorgu = vbNullString
End Sub

 

[Necdet]

Merhaba,

Aşağıdaki kodları deneyiniz.

Sub Cift_Kayit_Sil()
    
    Dim i   As Long
    Dim Son As Long
    Dim Adt As Long
    Dim Kol As Integer
    
    Application.ScreenUpdating = False
    
    Son = Cells(Rows.Count, "A").End(3).Row         'Son Satır
    Kol = Cells(1, Columns.Count).End(1).Column     'Son Kolon
    
    If Son < 2 Then Son = 2
    
    'Ad, Soyad ve Baba Adına göre sıralandı
    Range(Cells(2, "A"), Cells(Son, Kol)).Sort Key1:=[A1], Key2:=[B1], Key3:=[C1]
    
    For i = Son To 2 Step -1
        If Cells(i, "A") = Cells(i - 1, "A") And _
           Cells(i, "B") = Cells(i - 1, "B") And _
           Cells(i, "C") = Cells(i - 1, "C") Then
            Rows(i).Delete
            Adt = Adt + 1
        End If
    Next i
    
    Application.ScreenUpdating = True
    
    MsgBox Adt & " Adet Kayıt Çift Olduğundan Silindi....", vbInformation, "N. YEŞERTENER"
    
End Sub

 

[alptun20]

Her iki çözümde işimi gördü, ilginize teşekkürler. Saygılarımla...