各行のセルを個別に色付けする

Question

Excel シートのデータに色を付けたい:

各行を個別に確認し、データ値が等しいセルを同じ色で塗りつぶす必要があります。

以下のコードは、最初の 10 行のすべてのデータを反復処理し、各セルを異なる色で表示します。色付きのセルとその色を記憶する方法、および現在のセルがこの行のリストに既に記憶されている場合に新しい色ではなくその色を適用する方法がわかりません。

VBA で動的リストとして使用できるものはありますか? また、どのように使用できますか?

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

辞書を使用して、一意の値のカラーインデックスを取得できます。

---

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

---

注:これも背景色に基づいてフォントの色を決定します

---

結果