her değer kümesini ayrı renklendirme makrosu

[tkcargo]

Değerli forum üyeleri selamlar. Cumhuriyet Bayramımız kutlu olsun. Aşağıda, dosyamda kullandığım bir makro var ve countif ile belli aralıktaki aynı kelimeleri ayrı ayrı renklendiriyorum (Range("E9:E38")). Her değer kümesi için ayrı renk kullandığımdan koşullu biçimlendirme olmuyor. Sorunum şu ki range kısmına ilave hücreler eklediğimde hata alıyorum countif özelliği çalışmıyor(Range("E9 :E38,E41 :E58,E61,E62")). Ne önerirsiniz ya da farklı bir kod mu kullanmalıyım.

Dim ws As Worksheet
    Dim clr As Long
    Dim Rng As Range
    Dim cell As Range
    Dim R As Range
  
    Set ws = ActiveSheet
    Set Rng = ws.Range("D9:D38,D41:D58,D61,D62")
    With Rng
        Set R = .Cells(.Cells.Count)
    End With
    Rng.Interior.ColorIndex = xlNone
    clr = 37
    For Each cell In Rng
        If WorksheetFunction.CountIf(Rng, cell) > 0 Then
            If Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=R).Address = cell.Address Then
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cell.Interior.ColorIndex = Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=R).Interior.ColorIndex
            End If
        End If
    Next

 

[Muzaffer Ali]

Merhaba.
Aşağıdaki satırı silin

If WorksheetFunction.CountIf(Rng, cell) > 0 Then

Yerine aşağıdaki satırı kopyalayın.

If Not Rng.Find(What:=cell, LookAt:=xlWhole) Is Nothing Then

 

[tkcargo]

Muzaffer bey maalesef çalışmadı. Aşağıdaki kısma type mismatch hatası veriyor.
If Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=R).Address = cell.Address Then

Dim ws As Worksheet
    Dim clr As Long
    Dim Rng As Range
    Dim cell As Range
    Dim R As Range
   
    Set ws = ActiveSheet
    Set Rng = ws.Range("D9:D35,D38:D53,D56:D58")
    With Rng
        Set R = .Cells(.Cells.Count)
    End With
    Rng.Interior.ColorIndex = xlNone
    clr = 37
    For Each cell In Rng
        If Not Rng.Find(What:=cell, LookAt:=xlWhole) Is Nothing Then
            If Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=R).Address = cell.Address Then
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cell.Interior.ColorIndex = Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False, After:=R).Interior.ColorIndex
            End If
        End If
    Next

 

[Muzaffer Ali]

Deneyiniz.

Sub test()

    Dim clr As Long
    Dim Rng As Range
    Dim cell As Range
    Set Rng = Range("D9:D35,D38:D53,D56:D58")
    Rng.Interior.ColorIndex = xlNone
    clr = 37
    For Each cell In Rng
        If Not Rng.Find(What:=cell, LookAt:=xlWhole) Is Nothing Then
            If Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Address = cell.Address Then
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cell.Interior.ColorIndex = Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Interior.ColorIndex
            End If
        End If
    Next
End Sub

 

[tkcargo]

Deneyiniz.

Sub test()

    Dim clr As Long
    Dim Rng As Range
    Dim cell As Range
    Set Rng = Range("D9:D35,D38:D53,D56:D58")
    Rng.Interior.ColorIndex = xlNone
    clr = 37
    For Each cell In Rng
        If Not Rng.Find(What:=cell, LookAt:=xlWhole) Is Nothing Then
            If Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Address = cell.Address Then
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cell.Interior.ColorIndex = Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Interior.ColorIndex
            End If
        End If
    Next
End Sub

Muzaffer bey çabanız için teşekkür ederim kod çalışıyor ama bu sefer boş hücreleri de renklendirdi.

 

[Muzaffer Ali]

Deneyiniz.

Sub test()
    Dim clr As Long
    Dim Rng As Range
    Dim cell As Range
    Set Rng = Range("D9:D35,D38:D53,D56:D58")
    Rng.Interior.ColorIndex = xlNone
    clr = 37
    For Each cell In Rng
        If Not Rng.Find(What:=cell, LookAt:=xlWhole) Is Nothing Then
            If Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Address = cell.Address And Not cell = Empty Then
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cell.Interior.ColorIndex = Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Interior.ColorIndex
            End If
        End If
    Next
End Sub

 

[tkcargo]

Deneyiniz.

Sub test()
    Dim clr As Long
    Dim Rng As Range
    Dim cell As Range
    Set Rng = Range("D9:D35,D38:D53,D56:D58")
    Rng.Interior.ColorIndex = xlNone
    clr = 37
    For Each cell In Rng
        If Not Rng.Find(What:=cell, LookAt:=xlWhole) Is Nothing Then
            If Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Address = cell.Address And Not cell = Empty Then
                cell.Interior.ColorIndex = clr
                clr = clr + 1
            Else
                cell.Interior.ColorIndex = Rng.Find(What:=cell, LookAt:=xlWhole, MatchCase:=False).Interior.ColorIndex
            End If
        End If
    Next
End Sub

Muzaffer bey çok teşekkürler elinize sağlık.

 

[Muzaffer Ali]

Rica ederim. Kolay gelsin.