☰

Раскрашивание ячеек в каждой строке по-разному

tag-icon • tag-icon microsoft-excel vba
Раскрашивание ячеек в каждой строке по-разному

Я хочу раскрасить данные в своих таблицах 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

решение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

Примечание: Это такжеопределяет цвет шрифта на основе цвета фона

Результат

Лист1

Связанный контент