Excel VBA: CountIf (value criterion) AND (color criterion)

问题

I am trying to count the number of cells in a range that has the same color as a reference cells, IF the corresponding cell in another range has the correct value criterion. For example:

If (A1 < 350) and (B1 has the same color as a reference cell), then count 1. Loop over rows 1 to 15

It is essentially the same problem as the question posted here:
http://www.mrexcel.com/forum/excel-questions/58582-countif-multiple-criteria-one-being-interior-color.html

Unfortunately, it seems that the ExtCell.zip file no longer exit. Hence, I could not simply replicate the given solution. I tried to follow the same approach using the SUMPRODUCT function and I wrote a function for comparing cell color, but it did not work. I got the error "A value used in the formula is of the wrong data type." My code is as follow. I am using Excel 2007 on Windows 7. Any help is appreciated. Thanks!

=SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))

The formula above is keyed into a cell. B57:B65 contain some numerical values, while D57:D65 are colored cells. D307 is the reference cell with the correct color.

'' VBA function ColorCompare
Function ColorCompare(refCell As Range, compareCells As Range) As Variant
    Dim rCell As Range
    Dim TFresponses() As Boolean     'the boolean array to be returned to SUMPRODUCT

    Dim CallerCols As Long     'find out the number of cells input by the user 
                               'so as to define the correct array size
    With Application.Caller
        CallerCols = .Column.Count
    End With
    ReDim TFresponses(1 To CallerCols)

    Dim Idx As Long
    Idx = 1
    For Each rCell In compareCells
        If rCell.Interior.ColorIndex = refCell.Interior.ColorIndex Then
            TFresponses(Idx) = 1
            Idx = Idx + 1
        Else
            TFresponses(Idx) = 0
            Idx = Idx + 1
        End If
    Next rCell

    ColorCompare = TFresponses

End Function

回答1:

There are a couple of issues in your code

You need to determine the size of compareCells, not the caller cell
You are considering columns, should be Rows (or Rows and Columns for maximum flexability)
There are a few optimisations you can make

Here's a refactored version of your Function

Function ColorCompare(refCell As Range, compareCells As Range) As Variant
    Dim rCell As Range, rRw As Range
    Dim TFresponses() As Boolean     'the boolean array to be returned to SUMPRODUCT
    Dim rw As Long, cl As Long
    Dim clr As Variant

    clr = refCell.Interior.ColorIndex
    ReDim TFresponses(1 To compareCells.Rows.Count, 1 To compareCells.Columns.Count)

    rw = 1
    For Each rRw In compareCells.Rows
        cl = 1
        For Each rCell In rRw.Cells
            If rCell.Interior.ColorIndex = clr Then
                TFresponses(rw, cl) = True
            End If
            cl = cl + 1
        Next rCell
        rw = rw + 1
    Next rRw
    ColorCompare = TFresponses
End Function

Note that while this will return a result for any shaped range, to be useful in SumProduct pass it a range either 1 row high or 1 column wide - just as your sample formula does.

回答2:

Try this (updated for given formula: =SUMPRODUCT((B57:B65<350) * (ColorCompare(D307,D57:D65)))):

Sub test()
i = 57
While Not IsEmpty(Cells(i, 1))
If Cells(i, 2) < 350 And Cells(i, 4).Interior.ColorIndex = Cells(307, 4).Interior.ColorIndex Then 'replace with your reference cell
count = count + 1
End If
i = i + 1
Wend
End Sub

来源：https://stackoverflow.com/questions/27904416/excel-vba-countif-value-criterion-and-color-criterion

标签

excel

vba

excel-vba