MrExcel Publishing
Your One Stop for Excel Tips & Solutions

Counting colour filled cells

Posted by Nick on December 11, 2001 12:25 PM

I have a sheet which the user fills a cell with colour to show that it has been selected. How do I count how many cells in a column have been filled with a colour?

Posted by Tom Urtis on December 11, 2001 4:15 PM

One way to sort and count shaded cells

OK, let's say your range of shaded cells is in A2:A57. This code will sort those colored cells and create a pivot table starting in D1 to count for you how many of each kind of shaded color you have.
Remember, non-shaded cells are index # -4142, and each color has an index number from 1 to 56.

This code assumes you have no used cells in columns B:E that correspond to rows in Column A with the shaded cells. If you do, then modify the code as needed.
Name the header in cell A1 anything you want. The header in cell B1 in this code is "Color ID", so name your B1 header "Color ID".
Otherwise, adjust the macro for sort ascending, descending (or not at all if you don't want it sorted), sheet name, and range of interest.

Sub ColorID()

Application.ScreenUpdating = False

Dim Color As Range
For Each Color In Selection
Color.Cells(1, 2) = Color.Cells.Interior.ColorIndex
'Sort by color number
Selection.Sort Key1:=Range("B2"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

On Error GoTo a:
ActiveSheet.PivotTables("CellColorCount").PivotSelect "", xlDataAndLabel
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Sheet1!R1C1:R57C2").CreatePivotTable TableDestination:=Range("D1"), _
With ActiveSheet.PivotTables("CellColorCount")
.SmallGrid = False
.AddFields RowFields:="Color ID"
.PivotFields("Color ID").Orientation = xlDataField
.PivotFields("Sum of Color ID").Function = xlCount
End With
Application.CommandBars("PivotTable").Visible = False

Application.ScreenUpdating = True

End Sub

Hope this helps.

Tom Urtis

Posted by Holofernes on December 11, 2001 5:50 PM

Or .....

...... you could try a UDF :-

Function clr(r As Range) As Integer
Dim cell As Range, c As Integer
For Each cell In Intersect(r, ActiveSheet.UsedRange)
If cell.Interior.ColorIndex <> xlNone Then c = c + 1
clr = c
End Function