Soru Renklendirme Yardımı Hk.

[Erdogan3434]

Merhabalar,

Ekte örneği bulunan kodda A sütunun da bulunan isimleri E ile G sütunları arasında arıyor, bulduğumu yeşile boyuyorum. Sildiklerim beyaza dönüyor bulamadıklarım zaten beyaz kalıyor. Sizden ricam eğer söz konusu aralıkta aynı isim iki defa yazıyorsa A sütunundaki ismin kırmızı renge dönmesini sağlamaktır.

Desteğinizi rica ediyorum.

Saygılarımla.

 

[Korhan Ayhan]

Deneyiniz.

Option Explicit

Sub Ara_Renklendir()
    Dim Rng As Range, Dizi As Object, Aranan As String

    Set Dizi = VBA.CreateObject("Scripting.Dictionary")

    For Each Rng In Range("E:J").SpecialCells(xlCellTypeConstants)
        Aranan = UCase(Replace(Replace(Rng.Value, "ı", "I"), "i", "İ"))
        If Not Dizi.Exists(Aranan) Then
            Dizi.Item(Aranan) = 1
        Else
            Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
        End If
    Next
    
    For Each Rng In Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
        Aranan = UCase(Replace(Replace(Rng.Value, "ı", "I"), "i", "İ"))
        If Dizi.Exists(Aranan) Then
            If Dizi.Item(Aranan) = 1 Then
                Rng.Interior.Color = vbGreen
            Else
                Rng.Interior.Color = vbRed
            End If
        Else
            Rng.Interior.Color = xlNone
        End If
    Next
    
    Set Dizi = Nothing
    
    MsgBox "Arama işlemi tamamlanmıştır.", vbInformation
End Sub

 

[Erdogan3434]

Deneyiniz.

Option Explicit

Sub Ara_Renklendir()
    Dim Rng As Range, Dizi As Object, Aranan As String

    Set Dizi = VBA.CreateObject("Scripting.Dictionary")

    For Each Rng In Range("E:J").SpecialCells(xlCellTypeConstants)
        Aranan = UCase(Replace(Replace(Rng.Value, "ı", "I"), "i", "İ"))
        If Not Dizi.Exists(Aranan) Then
            Dizi.Item(Aranan) = 1
        Else
            Dizi.Item(Aranan) = Dizi.Item(Aranan) + 1
        End If
    Next
   
    For Each Rng In Range("A2:A" & Rows.Count).SpecialCells(xlCellTypeConstants)
        Aranan = UCase(Replace(Replace(Rng.Value, "ı", "I"), "i", "İ"))
        If Dizi.Exists(Aranan) Then
            If Dizi.Item(Aranan) = 1 Then
                Rng.Interior.Color = vbGreen
            Else
                Rng.Interior.Color = vbRed
            End If
        Else
            Rng.Interior.Color = xlNone
        End If
    Next
   
    Set Dizi = Nothing
   
    MsgBox "Arama işlemi tamamlanmıştır.", vbInformation
End Sub

Hocam bir günde ikinci kez beni ciddi bir zahmetten kurtarıyorsunuz. Size ne kadar teşekkür etsem az. Kod harika. Saygılarımla.