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.

QUALIFIERS:
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
Sheets("Sheet1").Range("A2:A57").Select

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

On Error GoTo a:
ActiveSheet.PivotTables("CellColorCount").PivotSelect "", xlDataAndLabel
Selection.Clear
a:
Sheets("Sheet1").Range("A1:B57").Select
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:= _
"Sheet1!R1C1:R57C2").CreatePivotTable TableDestination:=Range("D1"), _
TableName:="CellColorCount"
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
Range("A1").Select

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
Next
clr = c
End Function