birden fazla sütundaki değerler eşit ise mükerrer kayıt içine al

[mehdin82]

Arkadaşlar mükerrer kayıt ile alakalı çok yazı okudum ama sonucu bir türlü elde edemedim
sorunum şu elimde 3-4 sütundan ve 600 satırdan oluşan bir liste var benim istediğim 3-4 tane sütunun mesela 2 tanesinin eşitliği durumunda bir tanesi haricindekileri silmesi amacım ad soyad gibi bütün olarak değerlendirilmesi gereken kısımlarda mükerrer kayıt bulma

 

[Ömer]

Merhaba,

Module kopyalayıp çalıştırın.

Sub OzetAl()
 
    Dim d As Object, a1, deg, i As Long
 
    Set d = CreateObject("Scripting.Dictionary")
 
    Application.ScreenUpdating = False
    
    Sheets("Sayfa1").Select
    Range("D2:E" & Rows.Count).ClearContents
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
       deg = Cells(i, "A") & "|" & Cells(i, "B")
       If Not d.exists(deg) Then
           d.Add deg, Nothing
       End If
    Next i
    a1 = d.keys
    For i = 0 To d.Count - 1
        Cells(i + 2, "D") = Split(a1(i), "|")(0)
        Cells(i + 2, "E") = Split(a1(i), "|")(1)
    Next i
    
    Set d = Nothing
    Application.ScreenUpdating = True
 
End Sub

.

 

[mehdin82]

teşekkür ederim ömer bey ilginiz ve bilginiz için

 

[mehdin82]

peki ömer bey ilk mesajımda dediğim gibi bu kayıtlardan birini silmesi için kodda nasıl bir değişiklik yapmam lazım kaç kayıt olursa olsun 1 kayıda düşsün

 

[Ömer]

Farklı bir sütunda benzersizleri listelemek yerinde, veri üzerinde silinip işlem yapılmasını mı istiyorsunuz?

 

[mehdin82]

Farklı bir sütunda benzersizleri listelemek yerinde, veri üzerinde silinip işlem yapılmasını mı istiyorsunuz?

evet tam dediğiniz gibi yani clear content kısmını sildim zaten ama konuya çok hakim değilim ondan olumlu sonuç çıkaramadım
yaptığım listede mükerrer satırların birini silmek istiyorum

 

[tahsinanarat]

A ve B Sutununda aynı olan kayıtlardan birini bırakıp diğerlerini siler.
Sub mukerrersil()
For a = [a65536].End(3).Row To 1 Step -1
say = Evaluate("=SUMPRODUCT((A1:A" & a & "=A" & a & ")*(B1:B" & a & "=B" & a & "))")
If say > 1 Then Rows(a).Delete
Next
End Sub

 

[Ömer]

evet tam dediğiniz gibi yani clear content kısmını sildim zaten ama konuya çok hakim değilim ondan olumlu sonuç çıkaramadım
yaptığım listede mükerrer satırların birini silmek istiyorum

Alternatif olarak bu şekilde deneyin.

Sub YerindeOzetAl()
 
    Dim d As Object, a1, deg, i As Long
 
    Set d = CreateObject("Scripting.Dictionary")
 
    Application.ScreenUpdating = False
    
    Sheets("Sayfa1").Select
    
    For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
       deg = Cells(i, "A") & "|" & Cells(i, "B")
       If Not d.exists(deg) Then
           d.Add deg, Nothing
       End If
    Next i
    a1 = d.keys
    Range("A2:B" & Rows.Count).ClearContents
    For i = 0 To d.Count - 1
        Cells(i + 2, "A") = Split(a1(i), "|")(0)
        Cells(i + 2, "B") = Split(a1(i), "|")(1)
    Next i
    
    Set d = Nothing
    Application.ScreenUpdating = True
 
End Sub

.