VBA UDF ParamArray Sequence

Question

Я хочу создать функцию, почти такую ​​же, как SumIfs, но мне трудно понять, как нам обрабатывать часть ParamArray. Я ищу решение, которое позволяет использовать те же Range1,Criteria1,Range2,Criteria2,...,Rangen,Criterian в качестве суммы ifs, но в моей функции SumIfsContains. Я приложил код для единственного случая "SumIfContains", чтобы вы могли увидеть мою отправную точку:

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

Прежде чем я получил ответ прошлой ночью, я придумал рабочий вариант:

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

Но мне все еще любопытно, как сделать так, чтобы пара Range/Criteria позже не просто выделялась из массива "Criteria".

Answer 1

Если я правильно понимаю, что вы пытаетесь сделать, вам просто нужно перебрать ParamArrayStep 2, Добавьте тест, чтобы убедиться, что переданные параметры попали в пары, а затем просто захватите их как набор Criteria а также SumRange в цикле:

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

Вы заметите, что для SUMIFS, в отличие от SUMIF, диапазон данных идет первым. Это ключ к вашему 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