VBA function for array of RGB color combinations and procedure to color large number of cells with unique colors

Question

Submitting for review by experts.

Inspired by this question to color value cell having duplicates with a different color. So "Apple" will have one color for all duplicates. Then "Banana" will have a different color for all its duplicates. What if number of such values exceeds 56 (max number of ColorIndex property ?

With this function I am trying to create array of all possible combinations in a given range and step of RGB colors in VBA.

Starting from 1 and ending 255 there are 256*256*256 = 16,777,216 (1 is added for absence of color, 0) unique combinations of RGB colors. More than enough for all excel rows :) Refer this stackoverflow link. However Excel permits only 64000 format styles. Refer docs.microsoft.com

Function RGBColorArray(Optional StartCol As Byte = 150, Optional EndCol As Byte = 240, _
Optional Calc_ColStep As Boolean = True, Optional ColStep As Byte = 1, _
Optional Number_of_Cells As Long = 1, Optional Skip_Black As Boolean = False) As Variant
'This function gives array of combinations of colors
'Function will return error if StartCol or EndCol > 255
'StartCol is the color number from where to start. Say 150 default value
'EndCol is the color number where to end. Say 240 as default value
'Default 240 - 150 = 90 gives 90*90*90 = 729000 unique color combinations, enough for excel
'However Excel permits only 64000 format styles.
'Refer https://docs.microsoft.com/en-us/office/troubleshoot/excel/too-many-different-cell-formats-in-excel#:~:text=Cause,are%20applied%20to%20a%20cell.
'ColStep is the desired gap/interval between the two consecutive color combinations
'If every color combination is desired then ColStep = 1
'If every 5th color combination is desired then ColStep = 5

Start:
If Calc_ColStep = True Then
ColStep = (EndCol - StartCol) / WorksheetFunction.Max(((WorksheetFunction.RoundUp(Application.Power(Number_of_Cells, 1 / 3), 0)) - 2), 1)
    If ColStep < 1 Then 'This could happen if color range (end-start) is not enough for Number of cells is
    StartCol = 150
    EndCol = 240
    GoTo Start
    End If
End If

Dim RndEndCol As Integer
RndEndCol = StartCol + WorksheetFunction.MRound(EndCol - StartCol, ColStep)
If RndEndCol > 255 Then
EndCol = EndCol - ColStep
'Though this could be EndCol = RndEndCol - ColStep but it returns the same result of final array.
End If

Dim r As Byte, g As Byte, b As Byte, x As Byte, i As Long, j As Byte, k As Byte, l As Long
Dim arr As Variant, arrVal As Variant
x = 2 + (EndCol - StartCol) / ColStep
ReDim arr(1 To x ^ 3, 1 To 3)
    
StartCol = StartCol - ColStep
'_________________________________________
r = 0: l = 0
For i = 1 To x
    g = 0
    For j = 1 To x
        b = 0
        For k = 1 To x
            l = l + 1
            arr(l, 1) = r
            arr(l, 2) = g
            arr(l, 3) = b
            If b = 0 Then
            b = StartCol + ColStep
            Else
            If b <> 0 And k < x Then b = b + ColStep
            End If
        Next
        If b = 0 Then
        b = StartCol + ColStep
        Else
        If b <> 0 And k < x Then b = b + ColStep
        End If
        If g = 0 Then
        g = StartCol + ColStep
        Else
        If g <> 0 And j < x Then g = g + ColStep
        End If
    Next
    If b = 0 Then
    b = StartCol + ColStep
    Else
    If b <> 0 And k < x Then b = b + ColStep
    End If
    If g = 0 Then
    g = StartCol + ColStep
    Else
    If g <> 0 And j < x Then g = g + ColStep
    End If
    If r = 0 Then
    r = StartCol + ColStep
    Else
    If r <> 0 And i < x Then r = r + ColStep
    End If
Next

If Skip_Black = True Then
    For i = 2 To UBound(arr)
    arr(i - 1, 1) = arr(i, 1): arr(i - 1, 2) = arr(i, 2): arr(i - 1, 3) = arr(i, 3)
    Next i
End If

RGBColorArray = arr
    
End Function

So, following procedure will color range E1:E125 with different RGB color combinations returned by the above function. Function is RGBColorArray(150, 240, False, 30, , False). 125 cells is result of 5 step colors (0,150,180,210,240). So, 5*5*5 = 125

Sub ColorMyRange()
' This procedure colors each cell in a given range/ selection with unique color
Dim Number_of_Cells As Long, RGB_Start As Byte, RGB_End As Byte, rng As Range
Dim cell As Range, arr As Variant, i As Long, j As Long, x As Long

Set rng = Selection 'WWWWWWW Enter this Range
Number_of_Cells = rng.Cells.Count

RGB_Start = 10 'WWWWWWW Enter this value or default is 150
RGB_End = 240   'WWWWWWW Enter this value or default if 240
'If this color range is not enough for number of cells then formula uses default.

arr = RGBColorArray(RGB_Start, RGB_End, , , Number_of_Cells, True)
'True for skipping first combination row of RGBColorArray of black color RGB(0,0,0)
x = UBound(arr, 1)
Debug.Print UBound(arr, 1) & vbTab & UBound(arr, 2)
i = 1
For Each cell In Selection
    cell = arr(i, 1) & " | " & arr(i, 2) & " | " & arr(i, 3)
    cell.Interior.Color = RGB(arr(i, 1), arr(i, 2), arr(i, 3))
    i = i + 1
    Application.StatusBar = i
Next

End Sub

Column A, B and C contains array of RGBColorArray function

With following function we can calculate ColStep for the RGBColorArray function.

Function Calculate_ColStep(Number_of_Cells As Long, RGB_Start As Byte, RGB_End As Byte)
Calculate_ColStep = (RGB_End - RGB_Start) / ((WorksheetFunction.RoundUp(Application.Power(Number_of_Cells, 1 / 3), 0)) - 2)
End Function

Following function returns second half of the RGBColorArray upside down.

Function TwoDArraySecondHalf(myArray)
Dim myArray2ndHalf() As Variant

Dim a As Long, xa As Long, xb As Long, x2 As Long, b As Long, y As Long
Dim i As Long, j As Long
a = LBound(myArray, 1): xa = UBound(myArray, 1)
b = LBound(myArray, 2): y = UBound(myArray, 2)
xb = Int(xa / 2)
ReDim myArray2ndHalf(1 To (xa - xb), 1 To 3)
x2 = UBound(myArray2ndHalf, 1)
j = 1
For i = xa To (xb + 1) Step -1
    myArray2ndHalf(j, 1) = myArray(i, 1)
    myArray2ndHalf(j, 2) = myArray(i, 2)
    myArray2ndHalf(j, 3) = myArray(i, 3)
    j = j + 1
Next
TwoDArraySecondHalf = myArray2ndHalf
End Function

Using above functions in following procedure, we can color selected cells with alternate (dark/bright) unique colors while skipping black color (first element of RGBColorArray, RBG(0,0,0))

Sub ColorMyRangeAltCol()
' This procedure colors each cell in a given range/ selection with unique color
Dim Number_of_Cells As Long, RGB_Start As Byte, RGB_End As Byte, rng As Range
Dim cell As Range, arr As Variant, arr2 As Variant, i As Long, j As Long, x As Long
Dim Cell_Address As New Collection

Set rng = Selection 'WWWWWWW Enter this Range
Number_of_Cells = rng.Cells.Count

If Application.Power(Number_of_Cells, (1 / 3)) Mod 1 = 0 Then
Number_of_Cells = Number_of_Cells + 1
End If

RGB_Start = 215 'WWWWWWW Enter this value or default is 150
RGB_End = 216   'WWWWWWW Enter this value or default if 240
'If this color range is not enough for number of cells then formula uses default.

arr = RGBColorArray(RGB_Start, RGB_End, , , Number_of_Cells, True)
'True for skipping first combination row of RGBColorArray of black color RGB(0,0,0)
x = UBound(arr, 1)
arr2 = TwoDArraySecondHalf(arr)

arr = Application.Transpose(arr)
ReDim Preserve arr(1 To UBound(arr, 1), 1 To (UBound(arr, 2) - UBound(arr2, 1)))
arr = Application.Transpose(arr)

For Each cell In Selection
Cell_Address.Add cell.Address
Next

i = 1
For j = 1 To Cell_Address.Count Step 2
    Range(Cell_Address(j)) = arr(i, 1) & " | " & arr(i, 2) & " | " & arr(i, 3)
    Range(Cell_Address(j)).Interior.Color = RGB(arr(i, 1), arr(i, 2), arr(i, 3))
    If i > Cell_Address.Count / 2 Then Exit For
    Range(Cell_Address(j + 1)) = arr2(i, 1) & " | " & arr2(i, 2) & " | " & arr2(i, 3)
    Range(Cell_Address(j + 1)).Interior.Color = RGB(arr2(i, 1), arr2(i, 2), arr2(i, 3))
    i = i + 1
Next
End Sub

Following image shows such example for 250 cells.

With following procedure, we can randomly color each cell as shown in the image below.

Sub RandomColorMyRange()
' This procedure colors each cell in a given range/ selection with unique random color
Dim Number_of_Cells As Long, RGB_Start As Byte, RGB_End As Byte, rng As Range
Dim cell As Range, arr As Variant, i As Long, j As Long, x As Long
Dim ColorsColl As New Collection

Set rng = Selection 'WWWWWWW Enter this Range
Number_of_Cells = rng.Cells.Count

RGB_Start = 100 'WWWWWWW Enter this value or default is 150
RGB_End = 240   'WWWWWWW Enter this value or default if 240
'If this color range is not enough for number of cells then formula uses default.

arr = RGBColorArray(RGB_Start, RGB_End, , , Number_of_Cells, True)
'True for skipping first combination row of RGBColorArray of black color RGB(0,0,0)
x = UBound(arr, 1)

For j = 1 To UBound(arr, 1)
ColorsColl.Add arr(j, 1) & " | " & arr(j, 2) & " | " & arr(j, 3)
Next
ColorsColl.Remove (ColorsColl.Count)
'for removing last duplicate color caused by Skip_Black = True in the RGBColorArray function

For Each cell In Selection
    i = WorksheetFunction.RandBetween(1, ColorsColl.Count)
    cell = ColorsColl.Item(i)
    cell.Interior.Color = RGB(Split(ColorsColl.Item(i), "|")(0), _
                                Split(ColorsColl.Item(i), "|")(1), _
                                Split(ColorsColl.Item(i), "|")(2))
    ColorsColl.Remove (i)
    Application.StatusBar = ColorsColl.Count
Next

End Sub

Answer 1

I am posting this as an answer after many edits to the question and trials of the array function. Best one can be seen in this YouTube video. Fixed errors and following function is the result. Please suggest improvements. Thank you

Option Explicit
'WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW
Function Color_Array(Optional RGB_Array As Boolean = False, Optional Number_of_Cells As Long = 1, _
        Optional First_Shade As Byte = 140, Optional Last_Shade As Byte = 240, _
        Optional Shade_Step As Byte = 25, Optional Skip_Black As Boolean = True)
'--------------------------------------------------------------------------------------------
'This function gives array of combinations of RGB colors
'There are two array options
' -- > (1) RGB Array (values for red, green and blue) For this ensure "RGB_Array" boolean is true
' -- > (2) Long Color Values. For this ensure "RGB_Array" boolean is false
'First_Shade is the color number from where to start. Say 140 default value
'Last_Shade is the color number where to end. Say 240 as default value
'Default 240 - 150 = 90 gives 90*90*90 = 729000 unique color combinations, enough for excel
'However, Excel permits only 64000 format styles.
'Refer https://docs.microsoft.com/en-us/office/troubleshoot/excel/too-many-different-cell-formats-in-excel#:~:text=Cause,are%20applied%20to%20a%20cell.
'Shade_Step is the desired gap/interval between the two consecutive shades
'If every color combination is desired then Shade_Step = 1
'Say, if every 5th color combination is desired then Shade_Step = 5
'We can skip the first black color RGB(0,0,0), with Skip_Black = True
'--------------------------------------------------------------------------------------------
'Declaration of variables
Dim r As Byte, g As Byte, b As Byte ', Shade_Step As Byte
Dim i As Byte, j As Byte, k As Byte, l As Long, Number_Of_Shades As Long
Dim arr As Variant
'--------------------------------------------------------------------------------------------
'Caculations of variable values
Number_Of_Shades = WorksheetFunction.RoundUp((Number_of_Cells + 1) ^ (1 / 3), 0)
Shade_Step = WorksheetFunction.Min(Shade_Step, WorksheetFunction.RoundDown(((Last_Shade - First_Shade + 2) / (Number_Of_Shades - 1)), 0))
'--------------------------------------------------------------------------------------------
'Sizing array depending on whether RGB_Array and Skip_Black booleans are true or false
If RGB_Array = True Then
    If Skip_Black = True Then
        ReDim arr(1 To ((Number_Of_Shades ^ 3) - 1), 1 To 3)
    Else
        ReDim arr(1 To Number_Of_Shades ^ 3, 1 To 3)
    End If
Else
    If Skip_Black = True Then
        ReDim arr(1 To ((Number_Of_Shades ^ 3) - 1), 1 To 1)
    Else
        ReDim arr(1 To Number_Of_Shades ^ 3, 1 To 1)
    End If
End If
'--------------------------------------------------------------------------------------------
'Loop populating array
r = 0
l = 0
For i = 1 To Number_Of_Shades
    g = 0
    For j = 1 To Number_Of_Shades
        b = 0
        For k = 1 To Number_Of_Shades
            l = l + 1
'--------------------------------------
'Populate array depending on whether RGB_Array and Skip_Black booleans are true or false
            If RGB_Array = True Then
                If Skip_Black = True And l > 1 Then
                    arr(l - 1, 1) = r
                    arr(l - 1, 2) = g
                    arr(l - 1, 3) = b
                Else
                    arr(l, 1) = r
                    arr(l, 2) = g
                    arr(l, 3) = b
                End If
            Else
                If Skip_Black = True And l > 1 Then
                    arr(l - 1, 1) = RGB(r, g, b)
                    Else
                    arr(l, 1) = RGB(r, g, b)
                End If
            End If
'--------------------------------------
            If b = 0 Then b = First_Shade Else b = b + Shade_Step
        Next
        If g = 0 Then g = First_Shade Else g = g + Shade_Step
    Next
    If r = 0 Then r = First_Shade Else r = r + Shade_Step
Next
'--------------------------------------------------------------------------------------------
Color_Array = arr
End Function
'WWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWWW

Here is VBA code for the YouTube video.

Sub RandomColorMyRange()
' This procedure colors each cell in a given range/ selection with unique random color
Dim Number_of_Cells As Long, RGB_Start As Byte, RGB_End As Byte, rng As Range
Dim cell As Range, arr As Variant, i As Long, j As Long, x As Long
Dim ColorsColl As New Collection, CellAddress As New Collection

Set rng = Selection 'WWWWWWW Enter this Range
Number_of_Cells = rng.Cells.Count

RGB_Start = 100 'WWWWWWW Enter this value or default is 150
RGB_End = 240   'WWWWWWW Enter this value or default if 240
'If this color range is not enough for number of cells then formula uses default.

arr = Color_Array(False, Number_of_Cells, RGB_Start, RGB_End, 50, True)
'First boolena RGB_Array = false
'Second boolean Skip_Blank = True for skipping first row black color RGB(0,0,0)
'enter max shade_step (upto 255) for max rnage of colors
x = UBound(arr, 1)

For j = 1 To UBound(arr, 1)
ColorsColl.Add arr(j, 1)
Next

For Each cell In Selection
CellAddress.Add cell.Address
Next

For Each cell In Selection
    i = WorksheetFunction.RandBetween(1, ColorsColl.Count)
    j = WorksheetFunction.RandBetween(1, CellAddress.Count)
    
    If CellAddress.Count <> 1 Then
    Range(CellAddress.Item(j)) = ColorRGBValue(ColorsColl.Item(i), 2)
    Range(CellAddress.Item(j)).Interior.Color = ColorsColl.Item(i)
    ColorsColl.Remove (i)
    CellAddress.Remove (j)
    
    Else
    Range(CellAddress.Item(1)) = ColorRGBValue(ColorsColl.Item(i), 2)
    Range(CellAddress.Item(1)).Interior.Color = ColorsColl.Item(i)
    End If
    Application.StatusBar = CellAddress.Count
Next

End Sub

Following is additional procedure

Sub ColorMyRange() 'Not random
' This procedure colors each cell in a given range (or selection) with unique color at given shade_step
Dim Number_of_Cells As Long, RGB_Start As Byte, RGB_End As Byte, rng As Range
Dim cell As Range, arr As Variant, i As Long, j As Long, x As Long
Dim Cell_Address As New Collection

Set rng = Selection 'WWWWWWW Enter this Range
Number_of_Cells = rng.Cells.Count

RGB_Start = 100 'WWWWWWW Enter this value or default is 150
RGB_End = 240   'WWWWWWW Enter this value or default if 240
'If this color range is not enough for number of cells then formula uses default.

arr = Color_Array(False, Number_of_Cells, RGB_Start, RGB_End, 200, True)
'First boolena RGB_Array = false
'Second boolean Skip_Blank = True for skipping first row black color RGB(0,0,0)
'enter max shade_step (upto 255) for max rnage of colors
x = UBound(arr, 1)
'Debug.Print UBound(arr, 1) & vbTab & UBound(arr, 2)
i = 1
For Each cell In Selection
    cell = ColorRGBValue(arr(i, 1), 2)
    cell.Interior.Color = arr(i, 1) 'RGB(arr(i, 1), arr(i, 2), arr(i, 3))
    i = i + 1
    Application.StatusBar = i
Next

End Sub