每行的單元格都採用獨特的顏色

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

---

註：這也根據背景顏色決定字體顏色

---

結果