Yinelenen hücreleri boyama (makro)

[leonadies]

Arkadaşlar Merhaba;

bir süredir filtreleme yaptığımda çok aşırı yavaşlık sorunu yaşıyordum. Fark ettim ki bu soruna sebep olan şey "Koşullu biçimlendirme yinelenen değerleri renklendirme" seçeneğiymiş.

Şimdi bana lazım olan şey A2:A25000 aralığında mükerrer olarak girilen iki hücreyide kırmızıya boyaması . Sitede yapılan çalışmalara göz attım ancak malesef düzgün çalışanına rastlamadım. dosyamda tekrar olmamasına rağmen renklendiriyor sitedeki çalışmalar. Birde makronun A sütununa veri girdikçe işlemesi lazım. "Private Sub Worksheet_Change(ByVal Target As Range)" yapısıyla yani

 

[yanginci34]

Denermisiniz
Ekli dosyayı görüntüle MükerrerKontroldeneme.xlsm

 

[askm]

Koşullu biçimlendirmeye =EĞERSAY($A$2:A1;A1)>1 formülünü yazın. Dolgu rengini kırmızı ya da istediğiniz renk yapın.

 

[leonadies]

Denermisiniz
Ekli dosyayı görüntüle 194627

Üstadım Emeğine sağlık ancak bana böyle soru soran tarzlar değilde direk koşullu biçimlendirmenin yaptığı işi makro ile yaptırma yöntemi lazım. Yani A sütununa veri gireyim direk kendisi yorumlayıp hücreyi boyasın çalıştırsın.

 

[leonadies]

Koşullu biçimlendirmeye =EĞERSAY($A$2:A1;A1)>1 formülünü yazın. Dolgu rengini kırmızı ya da istediğiniz renk yapın.

Malesef dediğim gibi koşullu biçimlendirme filtrelemeyi çok agırlaştırıyor. Bana makrolu çözüm lazım.

 

[Ziynettin]

Merhaba,

Bu kodu deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then
        [A:A].Interior.ColorIndex = xlNone
        Set d = CreateObject("Scripting.Dictionary")
        Set a = Range("A2", [A65000].End(xlUp))
        For Each v In a
            If v <> "" And Target.Value = v.Value Then
                d(v.Value) = d(v.Value) + 1
            End If
        Next v
        For Each v In a
            If d(v.Value) > 1 Then
                v.Interior.ColorIndex = 3
            End If
        Next v
    End If
End Sub

 

[askm]

Tek buton ile komple işlem yapmak için;

Sub askm()
Application.ScreenUpdating = False
Dim son As Long
son = Range("A" & Rows.Count).End(3).Row
Range("A2:A" & son).Interior.ColorIndex = xlNone

For i = 2 To son
    If WorksheetFunction.CountIf(Range("A2:A" & son), Range("A" & i)) > 1 Then
        Cells(i, 1).Interior.ColorIndex = 3
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[leonadies]

Merhaba,

Bu kodu deneyiniz.

Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Column = 1 And Target.Row > 1 And Target.Count = 1 Then
        [A:A].Interior.ColorIndex = xlNone
        Set d = CreateObject("Scripting.Dictionary")
        Set a = Range("A2", [A65000].End(xlUp))
        For Each v In a
            If v <> "" And Target.Value = v.Value Then
                d(v.Value) = d(v.Value) + 1
            End If
        Next v
        For Each v In a
            If d(v.Value) > 1 Then
                v.Interior.ColorIndex = 3
            End If
        Next v
    End If
End Sub

Üstadım teşşekür ederim sorunsuz çalıştı

 

[leonadies]

Tek buton ile komple işlem yapmak için;

Sub askm()
Application.ScreenUpdating = False
Dim son As Long
son = Range("A" & Rows.Count).End(3).Row
Range("A2:A" & son).Interior.ColorIndex = xlNone

For i = 2 To son
    If WorksheetFunction.CountIf(Range("A2:A" & son), Range("A" & i)) > 1 Then
        Cells(i, 1).Interior.ColorIndex = 3
    End If
Next i
Application.ScreenUpdating = True
End Sub

Malesef bu kodlar iş yapmıyor. Alakasız tekrar etmeyen verileri boyuyor hocam

 

[baydeniro]

Teşekkürler askm, eline sağlık

 

[merrrakli]

Merhaba @Ziynettin Bey

Üstteki vermiş olduğunuz makroyu aşağıdaki şekilde bir sayfada nasıl çalıştırabilirim.

Data isimli makro ile oluşturduğum bir sayfam var ve bu sayfada E1:E200 arası sütunlarda bir ya da birden fazla tekrar eden verilerin arkaplanını renklendirmek istiyorum.

Kodunuz herhangi sabit bir excel sayfasına yazınca çalışıyor.

Ancak diğer işlemler sonucu macro ile oluşlan ve makro çalıştırıldığında silinip tekrar oluşturulan bir sayfaya bunu nasıl ekleyebiliriz