Satırları karşılaştırarak benzersizleri silme

[harpoon_1903]

Merhaba,
Örnek dosyada açıklandığı üzere, iki satırın karşılaştırılıp benzersiz kayıtların silinmesi gerekiyor. İlgilenecek hocalarıma şimdiden çok teşekkür ederim.

 

[N.Ziya Hiçdurmaz]

Yanıt

Sub BENZERSIZLER()
Dim D1, D2 As Range
For Each D1 In Range("A6:D17")
For Each D2 In Range("G6:M17")
If D1 = D2 Then
D2.Interior.ColorIndex = 6
End If
Next
Next
For Each D2 In Range("G6:M17")
If D2.Interior.ColorIndex <> 6 Then
D2 = 0
End If
D2.Interior.ColorIndex = xlNone
Next
End Sub

 

[harpoon_1903]

Sayın hocam,
Güzel bir çalışma olmuş, teşekkür ederim. Ancak sizin yazdığınız kodda alanlar karşılaştırılıyor. Ben ise her satırın kendi içinde karşılaştırılmasını istiyorum. Bunu nasıl yapabiliriz?

 

[N.Ziya Hiçdurmaz]

Yanıt

Kod biraz uzun olacak ama aşşağıdaki gibi her satır için ilave edilebilir.

Sub BENZERSIZLER()
Dim D1, D2 As Range
For Each D1 In Range("A6:D6")
For Each D2 In Range("G6:M6")
If D1 = D2 Then
D2.Interior.ColorIndex = 6
End If
Next
Next
For Each D2 In Range("G6:M6")
If D2.Interior.ColorIndex <> 6 Then
D2 = 0
End If
D2.Interior.ColorIndex = xlNone
Next
'************
For Each D1 In Range("A7:D7")
For Each D2 In Range("G7:M7")
If D1 = D2 Then
D2.Interior.ColorIndex = 6
End If
Next
Next
For Each D2 In Range("G7:M7")
If D2.Interior.ColorIndex <> 6 Then
D2 = 0
End If
D2.Interior.ColorIndex = xlNone
Next
End Sub

 

[harpoon_1903]

Sayın hocam,
Az önce uyarlamaları yapıp bitirdim. Sorunsuz çalışıyor. Gerçekten çok ihtiyacım vardı bu koda. Umarım başkalarının da işine yarar. Paylaştığınız için teşekkür ederim.