Belirli bir alanda birden fazla verilerin tamamını temizleme

[EKREM1661]

Merhabalar.. Belli bir alanda (örneğin E2:H20 olsun) birden fazla eşdeğer, yani tekrarlı veri varsa tamamını temizleyen bir kod çok lazım oldu arkadaşlar.. Yapılamazmı.? Çift verileri kaldıracak, sadece tek olanlarını bırakacak..

 

[EKREM1661]

güncelleme..

 

[Huseyinkis]

Ekteki kodları denermisiniz.

Sub cift()

For Each i In Range("E2:H20")
adet = WorksheetFunction.CountIf(Range("E2:H20"), i.Value)
If adet > 1 Then
i.Interior.Color = vbYellow
End If
Next i

For Each i In Range("E2:H20")
If i.Interior.Color = vbYellow Then
i.Interior.Color = xlNone
i.Value = Empty
End If
Next i



End Sub

 

[EKREM1661]

Hüseyin bey..! Ne diyeyim, ALLAH razı olsun diyorum.. Günlerdir çözemediğim ve sorup durduğum 2 konu idi; ikisini de halletmiş oldun.. Kodun ilk bölümü eşleşenleri renklendiriyor, ikinci bölümü de renklendiriyor ve siliyor..
Saygıdeğer Hüseyin hocam tam teşekkürlerimle birlikte muvaffakiyetler dilerim.

Hüseyin bey..! Ayrılmadan önce, yukarıdaki kodun 1.nci bölümü çift verileri renklendiriyordu. Bu eşleşen veriler iki ayrı sayfanın birer sütunun da olursa, bu durumda da çiftleri renklendirebilirmiyiz.
Diyelim ki, Sayfa1'in K sütunu ile Sayfa2'nin K sütununda veriler(isimler) olmuş olsun. Sayfa1 K sütununda olan bir isim, Sayfa2 K sütununda da var ise, ikisinide renklendirsin, istersek bunun yapılabilirliği var mı?. (Eğer seni uğraştıracaksa bu soruyu yok say..) Tekrar teşekkürler..

 

[Huseyinkis]

Teşekkürler.

Ekteki kodları dener misiniz sayfa1 ve sayfa2 ayrı ayrı kontrol eder.

Sub Renklendir()
Set s1 = Sheets("Sayfa1")
Set s2 = Sheets("Sayfa2")

s1.Select
son = s1.Cells(Rows.Count, "K").End(3).Row
For Each i In Range("K1:K" & son)
adet = WorksheetFunction.CountIf(s2.Range("K:K"), i.Value)
If adet > 1 Then
i.Interior.Color = vbYellow
End If
Next i


s2.Select
son = s2.Cells(Rows.Count, "K").End(3).Row
For Each i In Range("K1:K" & son)
adet = WorksheetFunction.CountIf(s1.Range("K:K"), i.Value)
If adet > 1 Then
i.Interior.Color = vbYellow
End If
Next i

End Sub

 

[EKREM1661]

Hüseyin hocam, tekrar teşekkür ederek; acaba ben mi uyarlayamadım, bilemiyorum, hoş görünüze binaen denemiş olduğum bir örnek dosyayı ekliyorum...
(1.Sayfada eksik bıraktığım isimlerin tamamı 2.sayfada var.. Şu halde her iki sayfada da mevcut bulunan isimleri renklendirecek idi..Tabii ki 1.sayfada olmayıp 2.sayfada olan isimler de öylecek kalacak..)

 

[Huseyinkis]

Diğer kodlarda çiftleri kendi aralığında aradığımızdan 1 den fazla olanlar için if adet>1 then
demiştik o kısmı değiştirmeyi unutmuşum 1'leri 0 olarak değiştirip denermisiniz.( if adet>0 then )

 

[EKREM1661]

Saygıdeğer Hüseyin bey..! Harikasınız, ellerinize sağlık, süper olmuş.. Yalnız, söylemeden geçemeyeceğim, isminizin altında uzman ibaresini görmek istiyorum..