Mükerrer kayıtin hücresini renklendirmek

[metin_0606]

8000 satırlık Excel veri sayfam var. Sayfanın ismi Ana Sayfa. Bu calisma sayfamın B sütununda TC kimlik No var, C sütununda ise İsim- Soy isim verileri var. Benim yapmak istediğim 8000 satırlık veri sayfamdaki mükerrer kayıtların bunldugu B ve C hücrelerinin dolgu rengini sarı renk yapmak. Yani isim- soy isim aynı ise sadece isim soy ismin bulunduğu hucrenin dolgu rengini sarı yapsın , eğer kişi aynı kişi ise hem TC kimlik nosunun bulunduğu hücreyi hemde isim soy isimin bulunduğu hucrenin dolgu rengini sarı yapsın. Bunu koşullu biçimlendirme ile yapıyorum ancak veri suz kısmını sayfamda kullanmak istediğimde veri suz kısmınin bulunduğu başlık hucresi adeta donuyor ve uzun süre sonra açılıyor. Belki makro ile bu sorun çözülebilir diye düşünüyorum. Yardımlarınız için şimdiden teşekkürler

 

[EmrExcel16]

Merhaba deneyiniz..

Sub Renklendir()
    Dim i
    For i = 1 To Cells(Rows.Count, 2).End(3).Row
        If WorksheetFunction.CountIf(Range("B1:B" & i), Cells(i, "B")) > 1 Then Cells(i, "B").Interior.ColorIndex = 6
        If WorksheetFunction.CountIf(Range("C1:C" & i), Cells(i, "C")) > 1 Then Cells(i, "C").Interior.ColorIndex = 6
    Next
End Sub

 

[metin_0606]

Merhaba deneyiniz..

Sub Renklendir()
    Dim i
    For i = 1 To Cells(Rows.Count, 2).End(3).Row
        If WorksheetFunction.CountIf(Range("B1:B" & i), Cells(i, "B")) > 1 Then Cells(i, "B").Interior.ColorIndex = 6
        If WorksheetFunction.CountIf(Range("C1:C" & i), Cells(i, "C")) > 1 Then Cells(i, "C").Interior.ColorIndex = 6
    Next
End Sub

Sayın emrexcel süre olarak makroyu hızlandırmak mümkün mü acaba veri sayısı çok olunca biraz uzun sürüyor

 

[PLİNT]

Merhaba
Emre bey'in hoşgörüsüne sığınarak;
aşağıdaki alternatifi denermisiniz? biraz süreyi kısaltacağını sanıyorum

Sub renk()
Dim dc As Object, lst(), i As Long, s1 As Worksheet
Set s1 = Sheets("Ana Sayfa")
Set dc = CreateObject("Scripting.Dictionary")
lst = s1.Range("B1:C" & s1.Cells(Rows.Count, "B").End(3).Row).Value
dc.CompareMode = vbTextCompare
For i = 1 To UBound(lst)
If Not dc.exists(lst(i, 1)) Then
dc.Add lst(i, 1), i
Else
s1.Range("B" & dc.Item(lst(i, 1))).Interior.ColorIndex = 6
s1.Range("B" & i).Interior.ColorIndex = 6
End If
If Not dc.exists(lst(i, 2)) Then
dc.Add lst(i, 2), i
Else
s1.Range("C" & dc.Item(lst(i, 1))).Interior.ColorIndex = 6
s1.Range("C" & i).Interior.ColorIndex = 6
End If
Next
End Sub

 

[EmrExcel16]

Estağfurullah Sayın PLİNT , bende bir alternatif hazırlamıştım , konu sahibi için ve forum için ne kadar alternatif o kadar iyi bence. Hem konu sahibi için kıyaslama olur .

Sub Test()
    Dim Zmn, Rng, Renk, Dizi
    Application.ScreenUpdating = False
    Zmn = Timer
    Set Rng = Range(Cells(1, 2), Cells(Cells(Rows.Count, 3).End(3).Row, 3))
    Rng.Interior.ColorIndex = xlNone
    Set Dizi = CreateObject("Scripting.Dictionary")
    For Each Renk In Rng
        If Renk <> "" Then
            Dizi(Renk.Value) = Dizi(Renk.Value) + 1
        End If
    Next
    For Each Renk In Rng
        If Dizi(Renk.Value) > 1 Then
            Renk.Interior.ColorIndex = 6
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Isleminiz tamam suresi  " & Format(Timer - Zmn, "0.00") & " Saniye"
End Sub

 

[PLİNT]

Yukarıdaki eklediğim kodlarda alttan yukarı 5.satırda (i, 1)
s1.Range("C" & dc.Item(lst(i, 1))).Interior.ColorIndex = 6
yerine (i, 2) olmalıydı
s1.Range("C" & dc.Item(lst(i, 2))).Interior.ColorIndex = 6

'....Kodlar
'.....'
Else
s1.Range("C" & dc.Item(lst(i, 2))).Interior.ColorIndex = 6   '<------------- Düzeltilen satır-----------
s1.Range("C" & i).Interior.ColorIndex = 6
End If
Next
End Sub

 

[Korhan Ayhan]

Sizin kullandığınız koşullu biçimlendirme formülü neydi?

 

[metin_0606]

Estağfurullah Sayın PLİNT , bende bir alternatif hazırlamıştım , konu sahibi için ve forum için ne kadar alternatif o kadar iyi bence. Hem konu sahibi için kıyaslama olur .

Sub Test()
    Dim Zmn, Rng, Renk, Dizi
    Application.ScreenUpdating = False
    Zmn = Timer
    Set Rng = Range(Cells(1, 2), Cells(Cells(Rows.Count, 3).End(3).Row, 3))
    Rng.Interior.ColorIndex = xlNone
    Set Dizi = CreateObject("Scripting.Dictionary")
    For Each Renk In Rng
        If Renk <> "" Then
            Dizi(Renk.Value) = Dizi(Renk.Value) + 1
        End If
    Next
    For Each Renk In Rng
        If Dizi(Renk.Value) > 1 Then
            Renk.Interior.ColorIndex = 6
        End If
    Next
    Application.ScreenUpdating = True
    MsgBox "Isleminiz tamam suresi  " & Format(Timer - Zmn, "0.00") & " Saniye"
End Sub

Sayın EmrExcel16 kodunuz gayet güzel çalışıyor 1 snde işlemi bitirdi. Size bir sorum olacak ben D ve E sütunlarındaki mükerrer kayıtlarda bu kodu çalıştırmak isteseydim kodun hangi kısmını revize etmem gerekirdi

 

[metin_0606]

Yukarıdaki eklediğim kodlarda alttan yukarı 5.satırda (i, 1)
s1.Range("C" & dc.Item(lst(i, 1))).Interior.ColorIndex = 6
yerine (i, 2) olmalıydı
s1.Range("C" & dc.Item(lst(i, 2))).Interior.ColorIndex = 6

'....Kodlar
'.....'
Else
s1.Range("C" & dc.Item(lst(i, 2))).Interior.ColorIndex = 6   '<------------- Düzeltilen satır-----------
s1.Range("C" & i).Interior.ColorIndex = 6
End If
Next
End Sub

Sayın PLİNT sizin vermiş olduğunuz kodda 1 sn de işlemi olması gerektiği gibi bitirdi. Yardımlarınız için teşekkür ederim. Konu hakkında paylaşılmış her iki koduda arşivime aldım. Değerli çalışmalar bunlar.

 

[metin_0606]

Sizin kullandığınız koşullu biçimlendirme formülü neydi?

korhan bey ben koşullu biçimlendirme-hücre vurgulama kuralları-yinelenen değerler şeklinde kullanıyordum. Buda yukarıdaki anlattığım sorun olarak karşıma çıkıyordu

 

[Korhan Ayhan]

Emre beyin kodundaki aşağıdaki satırı değiştirmelisiniz.

Değişen yerleri bold olarak belirttim. Sayısal değerler sütun indis numaralarıdır.

4 = D
5 = E

Set Rng = Range(Cells(1, 4), Cells(Cells(Rows.Count, 5).End(3).Row, 5))

 

[metin_0606]

Emre beyin kodundaki aşağıdaki satırı değiştirmelisiniz.

Değişen yerleri bold olarak belirttim. Sayısal değerler sütun indis numaralarıdır.

4 = D
5 = E

Teşekkürler Korhan bey