Excel VBA modification

Question

I have the following VBA code for a function that counts or sums cells if they have a specific background fill colour, given by a reference cell:

Function ColorFunction(rColor As Range, rRange As Range, Optional SUM As Boolean)

Dim rCell As Range
Dim lCol As Long
Dim vResult

lCol = rColor.Interior.ColorIndex

    If Count = True Then
       For Each rCell In rRange
          If rCell.Interior.ColorIndex = lCol Then
              vResult = WorksheetFunction.Count(rCell) + vResult
          End If
       Next rCell
    Else
       For Each rCell In rRange
          If rCell.Interior.ColorIndex = lCol Then
              vResult = 1 + vResult
          End If
       Next rCell
    End If

ColorFunction = vResult

End Function

As I am unfamiliar with the VBA environment, how do I modify this code to accept 2 cells as "baselines" for background fill colour and output the count/sum of a range if a row of cells contains both of the two input colours?

Answer 1

First thing to learn about VBA is unless you specify, it doesn't require variable declaration - any new variable referenced is automatically created as an uninitialized variant. This is useful for quick programming, but useless for anything more than toy programming.

Always put in Option Explicit as the first line in your modules, and it will throw an error when you use initialied=0 instead of initialized=0, instead of creating a new variable, and making it very difficult to debug...

I would also use CamelCase when defining variables, and keep typing in lower case - vba will capitalize as appropriate, so if you do type a variable wrong, it will not change to have upper case letters when you complete the line

Dim TestIt
testit = 1 'will change to TestIt = 1
testti = 1 'will not have upper case letters

That rant over, lets take a look at the program.

First thing we need to do is to check that you are actually giving 2 cells for the colors. This can be done by checking the cell count:

If rColor.Cells.Count <> 2 Then
    ...

next is to check we have at least 2 columns to check

If rRange.Columns.Count = 1 Then
    ....

finally we have to change the logic of the total/sum. Currently, it checks each cell individually, and there is no way to see if another color has been found on the same row, so we have to change that to check each row individually. This is most easily done by 2 nested For ... Next loops

Once we have done checking a row, then we need to check if both colors have been found. We can define a couple of flags to test that.

If rRange.Cells(LoopCols, LoopRows).Interior.ColorIndex = Color1 Then
    Find1stColor = True

and same for the 2nd color, and check at the end of the row with

If Find1stColor And Find2ndColor Then

Once we have that structure defined, we can then write our program:

Option Explicit

Function Color2Function(rColor As Range, rRange As Range, Optional SUM As Boolean)

Dim RowCount As Long
Dim ColCount As Long
Dim tempResult
Dim Color1 As Long
Dim Color2 As Long
Dim Totals
Dim LoopRows As Long
Dim LoopCols As Long
Dim Find1stColor As Boolean
Dim Find2ndColor As Boolean

If rColor.Cells.Count <> 2 Then
    Color2Function = CVErr(xlErrRef) 'Error 2023 returns #REF!
    Exit Function
End If

Color1 = rColor.Cells(1).Interior.ColorIndex
Color2 = rColor.Cells(2).Interior.ColorIndex

RowCount = rRange.Rows.Count
ColCount = rRange.Columns.Count

If ColCount = 1 Then
    Color2Function = 0 ' one column can never contain 2 colors
    Exit Function
End If

For LoopRows = 1 To RowCount
    Find1stColor = False
    Find2ndColor = False
    tempResult = 0
    For LoopCols = 1 To ColCount
        If rRange.Cells(LoopCols, LoopRows).Interior.ColorIndex = Color1 Then
            Find1stColor = True
            tempResult = tempResult + rRange.Cells(LoopCols, LoopRows).Value
        End If
        If rRange.Cells(LoopCols, LoopRows).Interior.ColorIndex = Color1 Then
            Find2ndColor = True
            tempResult = tempResult + rRange.Cells(LoopCols, LoopRows).Value
        End If
    Next
    If Find1stColor And Find2ndColor Then
        If SUM Then
            Totals = Totals + tempResult
        Else
            Totals = Totals + 1
        End If
    End If
Next

Color2Function = Totals

End Function

I leave it as an exercise for yourself to decide what to do if one of the colors is found more than once.