CountIFs with custom VBA Function

[ablackout]

Hello,

I created a custom VBA function {Color(Cell)}to return the background color value for a cell. I would like to be able to use a countifs statement to count how many cells in a range have the same color as a baseline cell and are within a certain daterange.

For example, I have a column with dates and different colors on sheet1.

21/6/2011
15/5/2011
26/6/2011
15/2/2010

On Sheet2, I have the following setup, and the cells under the 'Color Legend' are color coded and correspond to the colors in Sheet1

Color Legend | Total | May 2011 | June 2011
Open Task    |         |               |
In Progress   |         |               |
Completed    |         |               |

Thanks in Advance for any help.

 

[Ralajer]

Welcome to the board ablackout,

Because you are operating on the count over the return value of a function I believe you won't be able to use Countifs. You will have to use the sumproduct function. The below is an example of how it would work.

Excel Workbook
	A	B	C	D
1	Start Date	End Date
2	6/6/2003	8/1/2009
3			7/1/2000	7/1/2006
4	3		7/1/2001	7/1/2007
5			7/1/2002	7/1/2008
6			7/1/2003	7/1/2009
7			7/1/2004	7/1/2010
8			7/1/2005	7/1/2011
...

Cell Formulas
Range	Formula
A4	=SUMPRODUCT(--(Color(C3:D8)=Color(A2))*--(C3:D8>=A2)*--(C3:D8<=B2))

Your user defined function that returns cell color has to be able to handle and return arrays to be used by the sumproduct function. I am not sure if it does but I took the opportunity to write a color function that will return an array of color index's.
So try it with yours and if that doesn't work try the below.

Public Function COLOR(Optional rng As Range) As Variant

    Dim fxnCaller As Range
    
    Dim rngRows As Long
    Dim rngCols As Long
    Dim callerRows As Long
    Dim callerCols As Long
    
    Dim iRow As Long
    Dim iCol As Long
    
    Dim selfRef  As Boolean
    
    Dim callerAR() As Variant
    Dim rngAr() As Long
    
    Dim Returns As Variant
    
    Set fxnCaller = Application.Caller
    
    '// If the no range is passed use cell containing function
    '// Range is self reference Color()
    If IsMissing(rng) Or rng Is Nothing Then
        Set rng = fxnCaller
        selfRef = True
    End If
    '// Allow Single Continuous Rectangular Ranges
    '//  Return Value Error if Range is not continuous
    If rng.Areas.Count<> 1 Then Returns = CVErr(xlErrValue): GoTo earlyExit
    
    rngRows = rng.Rows.Count
    rngCols = rng.Columns.Count
    
    callerRows = fxnCaller.Rows.Count
    callerCols = fxnCaller.Columns.Count
    
    ReDim rngAr(1 To rngRows, 1 To rngCols)
    '// Populate array from input range
    For iRow = 1 To rngRows
        For iCol = 1 To rngCols
            rngAr(iRow, iCol) = rng(iRow, iCol).Interior.ColorIndex
        Next iCol
    Next iRow
    '// If the range passed is a self reference or the selected output range
    '//  is smaller than the input range then assign return value and goto end
    If selfRef Or (callerRows<= rngRows And callerCols<= rngCols) Then
        Returns = rngAr
        GoTo earlyExit
    End If
    
    ReDim callerAR(1 To callerRows, 1 To callerCols)
    
    For iRow = 1 To callerRows
        For iCol = 1 To callerCols
            '// Output array is larger then input range populated
            '// cell beyound the bounds with #N/A!
            If iRow > rngRows Or iCol > rngCols Then
                callerAR(iRow, iCol) = CVErr(xlErrNA)
            '// Output is within bounds of input
            Else
                callerAR(iRow, iCol) = rngAr(iRow, iCol)
            End If
        Next iCol
    Next iRow
    Returns = callerAR
   
earlyExit:
    COLOR = Returns
End Function