Zellen in jeder Zeile eindeutig einfärben

Question

Ich möchte die Daten in meinen Excel-Tabellen einfärben:

Ich muss jede Zeile einzeln betrachten und die Zellen mit gleichem Datenwert in der gleichen Farbe einfärben.

Der folgende Code iteriert alle Daten in den ersten 10 Zeilen und färbt jede Zelle anders. Ich bin nicht sicher, wie ich mir die gefärbten Zellen und ihre Farben dabei merken und diese Farbe anstelle der neuen Farbe anwenden kann, wenn die aktuelle Zelle bereits in einer Liste für diese Zeile gespeichert ist.

Gibt es etwas, das als dynamische Liste in VBA verwendet werden könnte, und wie?

Sub Test1()

    Dim x As Integer, rowInt As Integer, color As Integer
    Application.ScreenUpdating = False

    For rowInt = 1 To 10
        color = 3

        'numRows = number of cells before the first blank cell in the row ("A" & rowInt)
        numRows = Range("A" & rowInt, Range("A" & rowInt).End(xlToRight)).Columns.Count
        If numRows >= 16384 Then
            numRows = 1
        End If

        Range("A" & rowInt).Select
        For x = 1 To numRows

            With Selection.Interior
                .ColorIndex = color
                .Pattern = xlSolid
            End With

            color = color + 1

            ActiveCell.Offset(0, 1).Select
        Next
    Next

    Application.ScreenUpdating = True

End Sub

Answer 1

Sie können ein Wörterbuch verwenden, um den Farbindex für eindeutige Werte zu erfassen

---

Option Explicit

Public Sub ColorUniquesByRows()
    Const START_ROW = 2
    Dim ur As Range, arr As Variant, clrIndex As Long, i As Long, j As Long, ci As Long
    Dim cArr As Variant, r As Long, g As Long, b As Long, a As Double, d As Object

    Set ur = Sheet1.UsedRange   'Or ThisWorkbook.Worksheets("Sheet1").UsedRange
    Set d = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    arr = ur
    clrIndex = 3
    For i = START_ROW To UBound(arr)            'Iterate each row
        For j = 1 To UBound(arr, 2)             'Iterate each column (in current row)
            If Len(arr(i, j)) > 0 Then          'Ignore empty cells
                If Not d.Exists(arr(i, j)) Then 'Capture color index for each unique value
                    If clrIndex > 56 Then clrIndex = 3  'More than 56 columns - reset indx
                    ci = ThisWorkbook.Colors(clrIndex)  'Determine font color vs clr index
                    r = ci Mod 256: g = ci \ 256 Mod 256:   b = ci \ 65536 Mod 256
                    a = 1 - ((0.299 * r) + (0.587 * g) + (0.144 * b)) / 255
                    d(arr(i, j)) = clrIndex & " " & IIf(a < 0.5, vbBlack, vbWhite)
                    clrIndex = clrIndex + 1
                End If
                cArr = Split(d(arr(i, j)))
                With ur.Cells(i, j)
                    .Interior.colorIndex = cArr(0)
                    .Font.Color = cArr(1)
                End With
            End If
        Next j
        clrIndex = 3    'moving to next row: reset color index and dictionary object
        Set d = CreateObject("Scripting.Dictionary")
    Next i
    Application.ScreenUpdating = True
End Sub

---

Hinweis: Diesbestimmt die Schriftfarbe anhand der Hintergrundfarbe

---

Ergebnis