SumIf using background color as criteria

[ESeufert]

I want to write a function which will sum one range's values based on the background color of the cells in a different range. This would be as if I was using the function SumIf like so:

=sumif(A1:A20, "backgroundcolor=yellow", B1:B20)

I came up with this function, but, as you can probably imagine, it is painfully slow:

Function SumIfColor(checkColor As Range, checkRange As Range, sumRange As Range)
Dim checkCell As Range
Dim sumCell As Range
Dim lCol As Long
Dim vResult

lCol = checkColor.Interior.ColorIndex

For Each checkCell In checkRange
For Each sumCell In sumRange
If sumCell.Row = checkCell.Row Then
If checkCell.Interior.ColorIndex = lCol Then
vResult = WorksheetFunction.SUM(sumCell, vResult)
End If
End If
Next sumCell
Next checkCell

SumIfColor = vResult
End Function


I was having problems assigning that sumCell to the column of SumRange and the row of checkCell.

[mikerickson]

That code goes through two nesting loops, making checkRange.Count ^ 2 loops. You only need to check each cell once.

I modified your function in three ways.

1)Just as =SUMIF(range,criteria) returns the same value as =SUMIF(range,criteria,range), I made sumRange an optional argument with a default value of checkRange.

2) I introduced variables rowOffset and colOffset so that
(math not code)
checkRange = sumRange.offset(rowOffset,colOffset)

3)To make ranges (like A:A) smaller, I intersected sumRange with .UsedRange to cut down on the number of cells checked.

This is what I came up with:

Function SumIfColor(checkColor As Range, checkRange As Range, Optional sumRange As Variant)
'Dim checkCell As Range
Dim sumCell As Range
Dim lCol As Long
Dim vResult As Double
    Rem new variables
Dim subSumRange As Range
Dim rowOffset As Long
Dim colOffset As Long
    Rem optional sumRange handeling
If IsMissing(sumRange) Then Set sumRange = checkRange
If Not (IsObject(sumRange)) Then SumIfColor = CVErr(xlErrNA): Exit Function

lCol = checkColor.Interior.ColorIndex

rowOffset = checkRange.Row - sumRange.Row
colOffset = checkRange.Column - sumRange.Column

Set subSumRange = Application.Intersect(sumRange, sumRange.Parent.UsedRange)

If Not (Nothing Is subSumRange) Then
    For Each sumCell In subSumRange.Cells
        With sumCell.offset(rowOffset, colOffset)
            If .Interior.ColorIndex = lCol Then vResult = vResult + sumCell.Value
        End With
    Next sumCell
End If

SumIfColor = vResult
Exit Function

An even faster version is below. Unfortunatly, it uses .SpecialCells, which doesn't work right when called from a worksheet. (I use a Mac, you should check to see if this is true on PC's.) If you are only using the function from VB, this version only loops through cells containing number constants and formulas that evaluate to a number, skipping blanks, text, formulas that evaluate to text and errors.

Function SumIfColor(checkColor As Range, checkRange As Range, Optional sumRange As Variant)
'Dim checkCell As Range
Dim sumCell As Range
Dim lCol As Long
Dim vResult as Double

Dim subSumRange As Range
Dim rowOffset As Long
Dim colOffset As Long

If IsMissing(sumRange) Then Set sumRange = checkRange
If Not (IsObject(sumRange)) Then SumIfColor = CVErr(xlErrNA): Exit Function

lCol = checkColor.Interior.ColorIndex

rowOffset = checkRange.Row - sumRange.Row
colOffset = checkRange.Column - sumRange.Column

On Error Resume Next
Set subSumRange = sumRange.Cells.SpecialCells(xlCellTypeConstants, 1)

If Not Err Then
    For Each sumCell In subSumRange.Cells
        With sumCell.offset(rowOffset, colOffset)
            If .Interior.ColorIndex = lCol Then vResult = vResult + sumCell.Value
        End With
    Next sumCell
End If

On Error GoTo 0
On Error Resume Next

Set subSumRange = sumRange.Cells.SpecialCells(xlCellTypeFormulas, 1)

If Not Err Then
    For Each sumCell In subSumRange.Cells
        With sumCell.offset(rowOffset, colOffset)
            If .Interior.ColorIndex = lCol Then vResult = vResult + sumCell.Value
        End With
    Next sumCell
End If
On Error GoTo 0

SumIfColor = vResult
End Function

I hope this has helped.

[Bob Phillips]

See http://www.xldynamic.com/source/xld.ColourCounter.html for a working solution