Aynı değerdeki hücreleri renklendirme

[van_65166]

Merhaba

a stununda 5500 adet veri var 5500 verinin içinde 20 adet rakam var burdan aynı olanları reklendirmek istiyorum yardımcı olursanız sevinirim
örnek taplo

kod isim no değer
25 a 1 25
29 s 2 30
27 c 3 35
25 q 4 40
40 w 5 45
25 e 6 50
29 r 9 55
27 t 7 60
40 y 6 65
25 u 5 70
25 ı 4 75

yukardaki tabloda
kod a stunu
isim b stunu
no c sutnu
değer d sutunu

kod stununda olan aynı rakamları farklı renklere boyatabilirmiyiz

mesela 25 kırmızı 29 mavi 27 sarı gibi

yardımlarınız için şimdiden teşekkür ederim.

 

[Orion1]

Lütfen konu başlığınızı düzeltiniz.

 

[Korhan Ayhan]

Deneyiniz.

20 farklı sayı için çalışır. Daha fazla farklı sayınız varsa renk değişkenini arttırmanız gerekecektir. Okunaklı renkler tercih ettim. Siz dilerseniz linkteki makaleyi inceleyip değiştirebilirsiniz.

http://dmcritchie.mvps.org/excel/colors.htm

Option Base 1

Sub Renklendir()
    Application.ScreenUpdating = False
    Range("A:A").Interior.ColorIndex = xlNone
    Son = Cells(Rows.Count, 1).End(3).Row
    Renk = Array(3, 4, 5, 6, 7, 8, 23, 24, 33, 34, 35, 36, 38, 43, 44, 45, 46, 47, 48, 50)
    Say = 1
    For X = 2 To Son
        If Cells(X, 1).Interior.ColorIndex = -4142 Then
            If WorksheetFunction.CountIf(Range("A:A"), Cells(X, 1)) >= 1 Then
                Range("A:A").AutoFilter
                Range("A:A").AutoFilter 1, Cells(X, 1)
                Range("A2:A" & Son).SpecialCells(xlCellTypeVisible).Interior.ColorIndex = Renk(Say)
                Say = Say + 1
                If Say > 20 Then
                    MsgBox "Renk kartelası dolmuştur!" & Chr(10) & "Bazı hücrelerde renklendirme yapılamadı!", vbCritical
                    On Error Resume Next
                    ActiveSheet.ShowAllData
                    On Error GoTo 0
                    Exit Sub
                End If
            End If
        End If
    Next
    On Error Resume Next
    ActiveSheet.ShowAllData
    On Error GoTo 0
    Application.ScreenUpdating = False
    MsgBox "Renklendirme işlemi tamamlanmıştır."
End Sub