Sütun sayısal değerine göre hücre rengi atama

[adobul]

Merhaba,

Tüm aramalarıma rağmen bulamadığım bir kod için yardıma ihtiyacım var. Tablo uzun bir liste ve F sütununda sıraya sokulmuş sayısal değerler var. Bu veriler tekrar edebiliyor ve tekrar sayısı belli değil. Bu tabloyu F sütunundaki değerlere göre bir döngü şeklinde renk kodları atayabilir miyiz? Yani, F sütununda aynı değerleri bulup o hücreyi ( ya da tüm dolu satırı ) aynı renkle dolgu yapacak şekilde bir kod gerekmektedir.

Yardım için ilgilenenlere şimdiden teşekkürler...

 

[N.Ziya Hiçdurmaz]

yanıt

Sub bezerrenkle()
Dim sat As Integer
Dim s As Integer
s = 2
Range("r2:R" & Rows.Count).ClearContents
Range("f2:r" & Rows.Count).Interior.ColorIndex = xlNone
    For sat = 2 To Cells(Rows.Count, "f").End(xlUp).Row
        If WorksheetFunction.CountIf(Range("f2:F" & sat), Cells(sat, "f")) = 1 Then
        Cells(s, "r") = Cells(sat, "f")
        s = s + 1
        End If
    Next
    '
    For i = 20 To 56
        Cells(i - 18, "s").Interior.ColorIndex = i
     Next
     '
    son = Cells(Rows.Count, "r").End(xlUp).Row
    For sat = 2 To Cells(Rows.Count, "f").End(xlUp).Row
        Set bul = Range("r2:r" & son).Find(Cells(sat, "f"), , xlValues, xlWhole)
            If Not bul Is Nothing Then
                Cells(sat, "f").Interior.Color = Cells(bul.Row, "s").Interior.Color
            End If
    Next
    '
    Range("r2:s" & Rows.Count).Clear
End Sub

 

[adobul]

Sn. Ziya Bey,

Kod için çok teşekkür ederim, bu kadar kısa sürede çözüm bulmak çok güzel oldu
Bu türden bir kod örneğine ihtiyacı olanlar için de faydalı olacağını umarım.

Üstadım bilginize ve emeğinize sağlık ...

 

[adobul]

Merhaba Ziya Bey,

Bu kod 32000 satırlık bir listede çalışmadı ve overflow mesajı verdi. Satır sayısını yarıya indirdim, çok ağır da olsa çalıştı. Ancak 83. satıra kadar renklendirme yaptı. Tamamını ve 32000 gibi bir satırı olan tablo için nasıl yapabilirim? Bu kodu tekrar inceleyebilir misiniz...

 

[Korhan Ayhan]

Merhaba,

Ben iki renk kullanarak aynı sayıları renklendirdim. Aşağıdaki kodu denermisiniz.

Not: 50.000 satırlık bir veride 30.000 farklı sayısal değer üzerinde denedim. Yaklaşık 3 dakikada işlemi tamamladı.

Option Explicit
 
Sub AYNILARI_RENKLENDİR()
    Dim X As Long, Say As Long, Renk As Byte
 
    Application.ScreenUpdating = False
 
    Range("F:F").Interior.ColorIndex = xlNone
    Renk = 3
 
    For X = 2 To Cells(Rows.Count, 6).End(3).Row
        Say = WorksheetFunction.CountIf(Range("F:F"), Cells(X, 6))
        Range("F" & X & ":F" & X + Say - 1).Interior.ColorIndex = Renk
        X = X + Say - 1
        If Renk = 3 Then
            Renk = 6
        Else
            Renk = 3
        End If
    Next
 
    Application.ScreenUpdating = True
 
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[adobul]

Merhaba Korhan Hocam,

Bu sabah işe gelince kodu denedim, çalışıyor.. elinize emeğinize sağlık.. 2 renk olarak sarı kırmızı seçmişsiniz, bu da ayrıca kodu güzelleştirmiş