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

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

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


• Is there a reason you went to 240 instead of 255?
– Mast
Jun 15, 2020 at 8:03
• No , that is just for example to show how we can select the bottom and the top end. Like 120-220, 150-250, etc. Jun 15, 2020 at 9:21

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.
'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)
'--------------------------------------------------------------------------------------------
'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)
Next

For Each cell In Selection
Next

For Each cell In Selection
i = WorksheetFunction.RandBetween(1, ColorsColl.Count)

ColorsColl.Remove (i)

Else
End If
Next

End Sub


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

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


• ColorRGBValue function used in both the procedures above is this function named differently. Jun 30, 2020 at 15:09