1

I want to color the data in my excel sheets:

I need to look at each row separately, and color the cells with equal data value the same color.

The below code iterates all data in first 10 rows and colors each cell differently. I'm not sure how to remember the colored cells and their colors along the way, and apply that color instead of the new color if the current cell is remembered in a list already for this row.

Is there something that could be used as a dynamic list in vba, and how?

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 Answer 1

1

You could use a dictionary to capture the color index for unique values


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

Note: This also determines font color based on background color


Result

Sheet1

3
  • 1
    Thanks, just note that your code runs over columns rather than rows - can you edit your answer to fit the question so I can accept it.
    – Vepir
    Apr 1, 2018 at 11:09
  • 1
    I accepted your answer without running it myself (since I already implemented a modified version of your previous version of the answer), but after noticing your results now, I think you misread the question. Every row should be handled separately. For example, in your result table, based on those values, that means col 1 would be red, col 2 would be green, etc. Since each row should be treated as its own case of unique values. - I won't unaccept the answer, but you should fix your answer to fit the question. Also, I think the script should not continue to color empty cells per row.
    – Vepir
    Apr 2, 2018 at 10:26
  • 1
    Your last comment made it clearer - I updated the answer. As a note, the previous version continued to color empty cells because the UsedRange on your sheet contained some empty cells; that means that those cells contained data or formatting at some point but now are not being used. I updated the script to ignore empty cells just in case, but you might want to remove the extra rows (or columns) if not needed. To determine what Excel considers the "UsedRange" click Ctrl+End and it will select the last UsedCell on the sheet
    – paul bica
    Apr 2, 2018 at 13:15

You must log in to answer this question.

Not the answer you're looking for? Browse other questions tagged .