Hi Paul,
Here's my standard posting on this question
Counting coloured cells, either cell colour or font colour, is easily
achieved with the function presented at the foot of this message. The
function has been specifically designed to return an array of colorindex
values that can be used in standard worksheet functions, such as SUM. In
reality, it is best served by the SUMPRODUCT function to count the instances
of a particular colour, using the following technique(s).
=SUMPRODUCT(--(ColorIndex(A1:A100)=3))
counts all red cells (background color) within the range A1:A100
or
=SUMPRODUCT(--(ColorIndex(A1:A100,TRUE)=3))
counts all red cells (font color) within the range A1:A100
To get the colorindex of a specific cell, simply use
=ColorIndex(A1)
As well as counting all cells with a particular colorindex value, it is
possible to use the colour of a cell as the comparison, like this
=SUMPRODUCT(--(ColorIndex(A1:A100)=ColorIndex(A1)))
In addition, the function can be used to sort a range by its colour. Simply
add a 'helper' column next to the column of colours, and use the ColorIndex
to determine the original cell colour, and then sort both columns (and any
other appropriate columns), using the newly added 'helper' column as the key
range. Custom orders can be managed, but these would have to be defined
using the appropriate colorindex, there are no implicit colour names, such
as Red or Blue, that can be used
Adapt this to your requirements
------
'---------------------------------------------------------------------
Function ColorIndex(rng As Range, _
Optional text As Boolean = False) As Variant
'---------------------------------------------------------------------
' Function: Returns the colorindex of the supplied range
' Synopsis: Initially, gets a colorindex value for black and white from
' the activeworkbook colour palette
' Then works through each cell in the supplied range and
' determines the colorindex, and adds to array
' Finishes by returning acumulated array
' Variations: Determines cell colour (interior) or text colour (font)
' Default is cell colour
' Author: Bob Phillips
' Additions for ranges suggested by Harlan Grove
' Constraints: Does not count colours set by conditional formatting
'---------------------------------------------------------------------
Dim cell As Range, row As Range
Dim i As Long, j As Long
Dim iWhite As Long, iBlack As Long
Dim aryColours As Variant
If rng.Areas.Count > 1 Then
ColorIndex = CVErr(xlErrValue)
Exit Function
End If
iWhite = WhiteColorindex(rng.Worksheet.Parent)
iBlack = BlackColorindex(rng.Worksheet.Parent)
If rng.Cells.Count = 1 Then
If text Then
aryColours = DecodeColorIndex(rng, True, iBlack)
Else
aryColours = DecodeColorIndex(rng, False, iWhite)
End If
Else
aryColours = rng.Value
i = 0
For Each row In rng.Rows
i = i + 1
j = 0
For Each cell In row.Cells
j = j + 1
If text Then
aryColours(i, j) = _
DecodeColorIndex(cell,True,iBlack)
Else
aryColours(i, j) = _
DecodeColorIndex(cell,False,iWhite)
End If
Next cell
Next row
End If
ColorIndex = aryColours
End Function
'---------------------------------------------------------------------
Private Function WhiteColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
WhiteColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &HFFFFFF Then
WhiteColorindex = iPalette
Exit Function
End If
Next iPalette
End Function
'---------------------------------------------------------------------
Private Function BlackColorindex(oWB As Workbook)
'---------------------------------------------------------------------
Dim iPalette As Long
BlackColorindex = 0
For iPalette = 1 To 56
If oWB.Colors(iPalette) = &H0 Then
BlackColorindex = iPalette
Exit Function
End If
Next iPalette
End Function
'---------------------------------------------------------------------
Private Function DecodeColorIndex(rng As Range, _
text As Boolean, _
idx As Long)
'---------------------------------------------------------------------
Dim iColor As Long
If text Then
iColor = rng.font.ColorIndex
Else
iColor = rng.Interior.ColorIndex
End If
If iColor < 0 Then
iColor = idx
End If
DecodeColorIndex = iColor
End Function
'---------------------------------------------------------------------
' End of ColorIndex
'-------------------------------------------------
--
HTH
Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)
