Function ColorIndexOfRange(InRange As Range, _
Optional OfText As Boolean = False, _
Optional DefaultColorIndex As Long = -1) As Variant
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ColorIndexFromRange
' This function returns an array of values, each of which is
' the ColorIndex of a cell in InRange. If InRange contains both
' multiple rows and multiple columns, the array is two dimensional,
' number of rows x number of columns. If InRange is either a single
' row or a single column, the array is single dimensional. If
' InRange has multiple rows, the array is transposed before
' returning it. The DefaultColorIndex indicates what color
' index to value to substitute for xlColorIndexNone and
' xlColorIndexAutomatic. If OfText is True, the ColorIndex
' of the cell's Font property is returned. If OfText is False
' or omitted, the ColorIndex of the cell's Interior property
' is returned.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Arr() As Long
Dim NumRows As Long
Dim NumCols As Long
Dim RowNdx As Long
Dim ColNdx As Long
Dim CI As Long
Dim Trans As Boolean
Application.Volatile True
If InRange Is Nothing Then
ColorIndexOfRange = CVErr(xlErrRef)
Exit Function
End If
If InRange.Areas.Count > 1 Then
ColorIndexOfRange = CVErr(xlErrRef)
Exit Function
End If
If (DefaultColorIndex < -1) Or (DefaultColorIndex > 56) Then
ColorIndexOfRange = CVErr(xlErrValue)
Exit Function
End If
NumRows = InRange.Rows.Count
NumCols = InRange.Columns.Count
If (NumRows > 1) And (NumCols > 1) Then
ReDim Arr(1 To NumRows, 1 To NumCols)
For RowNdx = 1 To NumRows
For ColNdx = 1 To NumCols
CI = ColorIndexOfOneCell(Cell:=InRange(RowNdx, ColNdx), _
OfText:=OfText, DefaultColorIndex:=DefaultColorIndex)
Arr(RowNdx, ColNdx) = CI
Next ColNdx
Next RowNdx
Trans = False
ElseIf NumRows > 1 Then
ReDim Arr(1 To NumRows)
For RowNdx = 1 To NumRows
CI = ColorIndexOfOneCell(Cell:=InRange.Cells(RowNdx, 1), _
OfText:=OfText, DefaultColorIndex:=DefaultColorIndex)
Arr(RowNdx) = CI
Next RowNdx
Trans = True
Else
ReDim Arr(1 To NumCols)
For ColNdx = 1 To NumCols
CI = ColorIndexOfOneCell(Cell:=InRange.Cells(1, ColNdx), _
OfText:=OfText, DefaultColorIndex:=DefaultColorIndex)
Arr(ColNdx) = CI
Next ColNdx
Trans = False
End If
If IsObject(Application.Caller) = False Then
Trans = False
End If
If Trans = False Then
ColorIndexOfRange = Arr
Else
ColorIndexOfRange = Application.Transpose(Arr)
End If
End Function
Function ColorIndexOfOneCell(Cell As Range, OfText As Boolean, _
DefaultColorIndex As Long) As Long
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ColorIndexOfOneCell
' This returns the ColorIndex of the cell referenced by Cell.
' If Cell refers to more than one cell, only Cell(1,1) is
' tested. If OfText True, the ColorIndex of the Font property is
' returned. If OfText is False, the ColorIndex of the Interior
' property is returned. If DefaultColorIndex is >= 0, this
' value is returned if the ColorIndex is either xlColorIndexNone
' or xlColorIndexAutomatic.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim CI As Long
Application.Volatile True
If OfText = True Then
CI = Cell(1, 1).Font.ColorIndex
Else
CI = Cell(1, 1).Interior.ColorIndex
End If
If CI < 0 Then
If IsValidColorIndex(ColorIndex:=DefaultColorIndex) = True Then
CI = DefaultColorIndex
Else
CI = -1
End If
End If
ColorIndexOfOneCell = CI
End Function
Private Function IsValidColorIndex(ColorIndex As Long) As Boolean
Select Case ColorIndex
Case 1 To 56
IsValidColorIndex = True
Case xlColorIndexAutomatic, xlColorIndexNone
IsValidColorIndex = True
Case Else
IsValidColorIndex = False
End Select
End Function
