Count cells based on background color programmatically

This article demonstrates a VBA macro that counts cells based on their background color.

I got a question about counting background colors in a cell range. Excel uses two different properties to color cells and they are ColorIndex and Color property.

The ColorIndex property has 56 different colors, shown below.

The color property holds up to 16 777 216 colors. I tried to color 16 columns with 1048576 rows each (16 * 1048576 = 16 777 216) using the color property but excel returned this error after 65277 cells.

Back to top

2. VBA code

The following macro lets you count background colors, however, note that it won't count cells colored with conditional formatting.

'Name macro
Sub CountColors()
'This macro counts background colors in cell range
'https://www.get-digital-help.com/2017/03/30/count-colored-cells/

'Dimension variables and declare data types
Dim IntColors() As Long, i As Integer
Dim chk As Boolean

'Ask user for a cell range and save the output to range variable rng
Set rng = Application.InputBox("Select a cell range to count colors: ", , , , , , , 8)

'Redimension array variable IntColors
ReDim IntColors(0 To 2, 0)

'For Each ... Next statement
For Each cell In rng
chk = False
For c = LBound(IntColors, 2) To UBound(IntColors, 2)
If cell.Interior.ColorIndex = IntColors(0, c) And cell.Interior.Color = IntColors(1, c) Then
IntColors(2, c) = IntColors(2, c) + 1
chk = True
Exit For
End If
Next c

If chk = False Then
IntColors(0, UBound(IntColors, 2)) = cell.Interior.ColorIndex
IntColors(1, UBound(IntColors, 2)) = cell.Interior.Color
ReDim Preserve IntColors(2, UBound(IntColors, 2) + 1)
End If

Next cell

ReDim Preserve IntColors(2, UBound(IntColors, 2) - 1)

Set WS = Sheets.Add

WS.Range("A1") = "Color and count"
WS.Range("B1") = "ColorIndex"
WS.Range("C1") = "Color"
j = 1
For i = LBound(IntColors, 2) To UBound(IntColors, 2)
If IntColors(2, i) <> 0 Then
WS.Range("A1").Offset(j).Interior.ColorIndex = IntColors(0, i)
WS.Range("A1").Offset(j).Interior.Color = IntColors(1, i)
WS.Range("A1").Offset(j) = IntColors(2, i)
WS.Range("A1").Offset(j, 1) = IntColors(0, i)
WS.Range("A1").Offset(j, 2) = IntColors(1, i)
j = j + 1
End If
Next i
End Sub

Back to top

3. Where do I copy and paste the VBA code?

1. Select and copy code above (Ctrl+c).
2. Open VB Editor (Alt+F11).
3. Insert a new module to your workbook.
4. Paste code to code module.

Note, save your workbook with file extension *.xlsm (macro-enabled workbook) to keep the code attached to your workbook.

Back to top

4. Instructions

1. Press Alt + F8 to open the macro dialog box, it shows a list of macros currently in your open workbooks.
2. Press with mouse on macro CountColors with left mouse button to slect it.
3. Press the "Run" button on the dialog box.
4. Select a cell range you want to count.

The macro then creates a new sheet with cells in a column colored and their count, see picture below.

Value -4142  means No fill and -4105 is the default color (white).

There is no way to quickly transfer cell formatting properties to an array so the macro is quite slow, it reads a cell's property one by one. I don't recommend using this with larger cell ranges unless you are prepared to wait for a while.

Back to top

Get the Excel file

Rotating-unique-groups-with-no-repeatv2.xlsx

Back to top

Related articles

Find earliest and latest overlapping dates in a set of date ranges based on a condition
This article explains how to create a formula that returns the earliest (smallest) and the latest (largest) date of overlapping […]