Soru 3 Sütunda Mükerrer Girildiğine 3 Satırında Renklenmesi.

[Seceren]

3 Sütunda mükerrer girildiğine 3 satırında renklenmesi.
Eklediğim dosyada kod revize edilerek veya başka bir kodla da yapıla bilir.

İndir

Dosyayı indir

dosya.co

 

[YUSUF44]

Aşağıdaki kodu kullanabilirsiniz. Ancak verileriniz çoğaldıkça işlem hızı düşecektir. Sürekli olarak her değişiklikte döngüyle tüm satırları kontrol etmek mantıklı değil:

Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, [A2:C65536]) Is Nothing Then Exit Sub
Dim Son As Long
Son = [A65536].End(3).Row
Application.ScreenUpdating = False
Range("A2:C" & Son).Interior.ColorIndex = xlNone
For i = Son To 2 Step -1
    If WorksheetFunction.CountIfs(Range("A2:A" & Son), Cells(i, "A"), Range("B2:B" & Son), Cells(i, "B"), Range("C2:C" & Son), Cells(i, "C")) > 1 Then
        Range("A" & i & ":C" & i).Interior.ColorIndex = 7
    End If
Next i
Application.ScreenUpdating = True
End Sub

 

[Seceren]

Biliyorum, genede denemek istedim. Yardımın için çok teşekkür ederim.

 

[Korhan Ayhan]

Bu biraz daha hızlı sonuç verebilir.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim Son As Long, Veri As Variant, X As Long, Alan As Range
    If Intersect(Target, Range("A2:C" & Rows.Count)) Is Nothing Then Exit Sub
    Application.ScreenUpdating = False
    Son = Cells(Rows.Count, 1).End(3).Row
    Veri = Range("A2:C" & Son).Value
    Range("A2:C" & Rows.Count).Interior.ColorIndex = xlNone
    With CreateObject("Scripting.Dictionary")
        For X = LBound(Veri) To UBound(Veri)
            Aranan = Veri(X, 1) & Veri(X, 2) & Veri(X, 3)
            If Aranan <> "" Then
                If Not .Exists(Aranan) Then
                    .Add Aranan, Nothing
                Else
                    If Alan Is Nothing Then
                        Set Alan = Cells(X + 1, 1).Resize(1, 3)
                    Else
                        Set Alan = Union(Alan, Cells(X + 1, 1).Resize(1, 3))
                    End If
                End If
            End If
        Next
    End With
    If Not Alan Is Nothing Then Alan.Interior.ColorIndex = 7
    Application.ScreenUpdating = True
End Sub

 

[Seceren]

Bu biraz daha hızlı sonuç verebilir.

Teşekkürler, eline sağlık daha ne olsun!?