VBA UDF ParamArray Sequenz

Question

Ich möchte eine Funktion erstellen, die fast genau wie SumIfs ist, aber es fällt mir schwer, herauszufinden, wie wir mit dem ParamArray-Teil umgehen. Ich suche nach einer Lösung, die den gleichen Range1, Criteria1, Range2, Criteria2, ..., Rangen, Criterian als Summe ifs aber in meiner "SumIfsContains" -Funktion erlaubt. Ich habe den Code für den Einzelfall angebracht, „SumIfContains“ so können Sie meine Ausgangspunkt sehen:

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 

Bevor ich eine Antwort gestern Abend habe ich mit einem Arbeits Option kam sich wie folgt zusammen:

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 

Aber ich bin immer noch neugierig, wie das Range/Criteria-Paar später nicht einfach aus dem Array "Kriterien" parst.

Answer 1

Wenn ich richtig verstehe, was Sie versuchen, zu tun, müssen Sie nur über die ParamArrayStep 2 iterieren. Fügen Sie einen Test, um sicherzustellen, als die übergebenen Parameter kommen paarweise, dann greifen sie nur als eine Reihe von Criteria und SumRange in einer Schleife:

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

Sie werden beachten, dass für SUMIFS, im Gegensatz zu SUMIF, den Datenbereich kommt zuerst. Das ist der Schlüssel zu Ihrem 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