Sütundaki Farklı Verileri Farklı Renlendirme

[askm]

Kolay gelsin.
F Sütunundaki değerler değiştikçe A ile L arasındaki hücre renkleri değişmesini nasıl sağlayabilirim. Yani aynı veriye aynı renk gelecek şekilde yapmak istiyorum.

 

[dragonflyvtr]

Tesekkurler

 

[askm]

Aşağıdaki kodlarla farklıları başka yere alıyor. Benim istediğim bununla birlikte renklenmesini nasıl sağlarım.

Private Sub Worksheet_Change(ByVal Target As Range)
    Range("f4:f1000").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range( _
        "p1"), Unique:=True
End Sub

 

[Korhan Ayhan]

Excelin okunabilir renk paleti sınırlıdır.

Sizin kaç farklı veriniz var.

 

[askm]

Maksimum 20 veya 25 tane verim var. Biliyorum 56 tane renk paleti var.

 

[askm]

Aşağıdaki kodlar ile hem özet tablo hemde biçimlendirme yaptım.

Sub Benzersiz()
Dim son As Long
Dim fontrenk As Integer
Dim Renk As Integer
Renk = 3
fontrenk = 56


Columns("p:q").ClearContents
Columns("p:q").Interior.ColorIndex = 0 ' xlNone
Columns("p:q").Font.ColorIndex = 0 'xlNone

'Sheets("sayfa1").Range("f5:F65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Sheets("sayfa2").Range("A1"), Unique:=True
Range("f4:F65536").AdvancedFilter Action:=xlFilterCopy, CopyToRange:=Range("P1"), Unique:=True


son = Range("p65000").End(xlUp).Row  'son hucreye A sutunundan baktIm

For i = 2 To son
    If Renk = 56 Then
        Renk = 1
        fontrenk = 56
    End If
    Cells(i, 17).FormulaR1C1 = "=IF(RC[-1]="""","""",COUNTIF(R5C6:R1001C6,RC[-1]))"
     Range("P" & i & ":Q" & i).Interior.ColorIndex = Renk
     Range("P" & i & ":Q" & i).Font.ColorIndex = fontrenk
     Renk = Renk + 1
     fontrenk = fontrenk - 1
Next
 Call Bicimlendir
 Columns("p:q").Font.Bold = True
 
 ActiveSheet.PageSetup.PrintArea = "$P$1:$Q$20,$A$1:$I$" & Range("A65536").End(3).Row
 ActiveSheet.PageSetup.Zoom = 75
End Sub
Sub Bicimlendir()
'
' Makro7 Makro
'

'

Dim son As Long
Dim son2 As Long
Dim satir As Integer

On Error Resume Next
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

son = Range("p65000").End(xlUp).Row  'son hucreye A sutunundan baktIm
son2 = Range("f65000").End(xlUp).Row  'son hucreye A sutunundan baktIm
''''''''''''''''''''''''''''''''''''''
Columns("f:f").Interior.ColorIndex = 0 ' xlNone
Columns("f:f").Font.ColorIndex = 0 'xlNone
For X = 2 To son
    Range("p" & X).Select
    Selection.Copy
    For i = 4 To son2 'Range("f65536").End(3).Row To 1 Step -1
        Range("s1") = ""
       Set k = Range("F" & i & ":F1000").Find(Range("p" & X).Value, , xlValues, xlWhole)
       
       If k = Range("p" & X).Value Then
       k.Select
       
       End If
       satir = k.Row
       Range("A" & satir & ":I" & satir).Select
        Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
        SkipBlanks:=True, Transpose:=False
        'Rows(i).Delete
    Next i
Next X
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
''''''''''''''''''''''''''''''''''''''

    
End Sub