VBA UDF ParamArray Sequence - vba

Question

I want to create a function that is almost exactly like SumIfs, but I'm having a hard time figuring our how to handle the ParamArray portion. I'm looking for a solution that allows the same Range1,Criteria1,Range2,Criteria2,...,Rangen,Criterian as the sum ifs but in my "SumIfsContains" function. I've attached the code for the singular case, "SumIfContains" so you can see my starting point:
Function SumIfContains(PhraseRange As Range, Criteria As String, SumRange As Range)
Dim element As Range
ElementCount = 0
For Each element In PhraseRange
ElementCount = ElementCount + 1
Next element
Dim SumArray: ReDim SumArray(1 To 3, 1 To ElementCount)
ElementCount = 0
For Each element In SumRange
ElementCount = ElementCount + 1
SumArray(2, ElementCount) = element
Next element
ElementCount = 0
For Each element In PhraseRange
ElementCount = ElementCount + 1
SumArray(1, ElementCount) = element
If InString(CStr(element), Criteria) Then
SumArray(3, ElementCount) = SumArray(2, ElementCount)
Else
SumArray(3, ElementCount) = 0
End If
Next element
SumIfContains = 0
For Item = 1 To ElementCount
SumIfContains = SumIfContains + CDbl(SumArray(3, Item))
Next Item
End Function
Before I got an answer last night I came up with a working option as follows:
Function SumIfsContains(SumRange As Range, ParamArray Criteria() As Variant)
Dim element As Range
Dim cCriteria As String
Dim PhraseRange As Range
'Exit Function
Dim PhraseRangeArray(): ReDim PhraseRangeArray(LBound(Criteria()) To (((UBound(Criteria()) + 1) / 2) - 1))
Dim CriteriaArray(): ReDim CriteriaArray(LBound(Criteria()) To (((UBound(Criteria()) + 1) / 2) - 1))
CurrentPair = 0
For i = LBound(Criteria()) To UBound(Criteria())
If i Mod 2 = 0 Then
PhraseRangeArray(CurrentPair) = Criteria(i)
Else
CriteriaArray(CurrentPair) = Criteria(i)
CurrentPair = CurrentPair + 1
End If
Next i
ElementCount = UBound(PhraseRangeArray(0))
Dim SumRng: ReDim SumRng(1 To ElementCount)
i = 1
For Each element In SumRange
SumRng(i) = element
i = i + 1
Next element
Dim SumArray: ReDim SumArray(0 To 2 + UBound(PhraseRangeArray), 1 To ElementCount)
For i = 1 To ElementCount
SumArray(1, i) = SumRng(i)
For RC = 2 To 2 + UBound(PhraseRangeArray)
If InString(CStr(PhraseRangeArray(RC - 2)(i, 1)), CStr(CriteriaArray(RC - 2))) Then
SumArray(RC, i) = 1
Else
SumArray(RC, i) = 0
End If
Next RC
SumArray(0, i) = SumArray(1, i)
For Mult = 2 To 2 + UBound(PhraseRangeArray)
SumArray(0, i) = SumArray(0, i) * SumArray(Mult, i)
Next Mult
Next i
SumIfsContains = 0
For Item = 1 To ElementCount
SumIfsContains = SumIfsContains + CDbl(SumArray(0, Item))
Next Item
End Function
But I'm still curious how to make the Range/Criteria pair not simply be parced out of the "Criteria" array later.

Answer 1

If I understand correctly what you're trying to do, you just need to iterate over the ParamArray Step 2. Add a test to make sure than the passed parameters come in pairs, then just grab them as a set of Criteria and SumRange in a loop:
Public Function PairedParamArrayIe(PhraseRange As Range, ParamArray values())
Dim counter As Integer
Dim Criteria As String
Dim SumRange As Range
If UBound(values) Mod 2 <> 1 Then
Err.Raise -1, vbNullString, "Invalid ParamArray"
End If
For counter = LBound(values) + 1 To UBound(values) Step 2
Criteria = values(counter - 1)
Set SumRange = values(counter)
Debug.Print Criteria
Debug.Print SumRange.AddressLocal
Next counter
End Function

Answer 2

You'll note that for SUMIFS, unlike SUMIF, the data range comes first. That's key to your ParamArray:
Function SumIfContains(SumRange As Range, ParamArray criteria())
Dim x As Long
Dim n As Long
Dim dTotal As Double
Dim bMatch As Boolean
' check for criteria ranges
For n = LBound(criteria) To UBound(criteria) Step 2
If TypeName(criteria(n)) <> "Range" Then
SumIfContains = CVErr(xlErrNum)
End If
Next n
' loop through each cell in sum range
For x = 1 To SumRange.Cells.Count
bMatch = True
' loop through criteria
For n = LBound(criteria) To UBound(criteria) Step 2
' first item in pair is the range, second is the criterion
If InStr(1, criteria(n).Cells(x).Value2, criteria(n + 1), vbTextCompare) = 0 Then
' if one doesn't match, set a flag and exit the loop
bMatch = False
Exit For
End If
Next n
' only if all criteria matched is bMatch still True, and we add the sumrange cell
If bMatch And IsNumeric(SumRange.Cells(x).Value2) Then dTotal = dTotal + SumRange.Cells(x).Value2
Next x
SumIfContains = dTotal
End Function