加权平均 IFS UDF

Question

I am trying to make a Weighted Average Ifs function with the capability of having up to three ifs. as it stands, the function only works when the optionality is removed and all arguments are filled by the user. When the function is run #Value. is returned when optional arguments are not filled. here is the complete code in question.

Function WeightedAvgIfs(ByVal values As Range, ByVal weights As Range, _
ByVal ConditionRange1 As Range, ByVal Condition1 As String, _
Optional ByVal ConditionRange2 As Range = Nothing, Optional ByVal Condition2 As String = "=ZZZ", _
Optional ByVal ConditionRange3 As Range = Nothing, Optional ByVal Condition3 As String = "=ZZZ") As Double

Dim ValuesArray(), WeightsArray(), Condition1Array(), Condition2Array(), Condition3Array() As Variant
Dim i As Long
Dim dsum As Double
Dim StringOperator As String
Dim Condition As Variant

ValuesArray = Range(values.Address(1, 1, xlA1, 1))
WeightsArray = Range(weights.Address(1, 1, xlA1, 1))
Condition1Array = Range(ConditionRange1.Address(1, 1, xlA1, 1))
Condition2Array = Range(ConditionRange2.Address(1, 1, xlA1, 1))
Condition2Array = Range(ConditionRange3.Address(1, 1, xlA1, 1))

'Condition 1
For i = LBound(ValuesArray) To UBound(ValuesArray)

    Select Case Left(Condition1, 2)
        Case Is = "<="
            StringOperator = "<="
            Condition = Val(Mid(Condition1, 3, Len(Condition1)))
        Case Is = ">="
            StringOperator = ">="
            Condition = Val(Mid(Condition1, 3, Len(Condition1)))
        Case Is = "<>"
            StringOperator = "<>"
            If IsNumeric(Mid(Condition1, 3, Len(Condition1))) And Not IsEmpty(Condition1) Then
                Condition = Val(Mid(Condition1, 3, Len(Condition1)))
            Else
                Condition = UCase(Mid(Condition1, 3, Len(Condition1)))
            End If
        
        Case Else
            Select Case Left(Condition1, 1)
                Case Is = "<"
                    StringOperator = "<"
                    Condition = Val(Mid(Condition1, 2, Len(Condition1)))
                Case Is = ">"
                    StringOperator = ">"
                    Condition = Val(Mid(Condition1, 2, Len(Condition1)))
                Case Is = "="
                    StringOperator = "="
                    If IsNumeric(Mid(Condition1, 2, Len(Condition1))) And Not IsEmpty(Condition1) Then
                        Condition = Val(Mid(Condition1, 2, Len(Condition1)))
                    Else
                        Condition = UCase(Mid(Condition1, 2, Len(Condition1)))
                    End If
            End Select
    End Select
    Select Case StringOperator
        Case Is = ">="
            If Condition1Array(i, 1) < Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = ">"
            If Condition1Array(i, 1) <= Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = "<="
            If Condition1Array(i, 1) > Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = "<"
            If Condition1Array(i, 1) >= Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Else
            Select Case StringOperator
                Case Is = "="
                    If IsNumeric(Condition1Array(i, 1)) And Not IsEmpty(Condition1Array(i, 1)) Then
                        If Val(Condition1Array(i, 1)) <> Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    Else
                        If UCase(CStr(Condition1Array(i, 1))) <> Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    End If
                Case Is = "<>"
                    If IsNumeric(Condition1Array(i, 1)) And Not IsEmpty(Condition1Array(i, 1)) Then
                        If Val(Condition1Array(i, 1)) = Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    Else
                        If UCase(CStr(Condition1Array(i, 1))) = Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    End If
            End Select
    End Select
    
Next i

If ConditionRange2 Is Nothing Then
    GoTo FinalCalc
End If

'Condition 2

For i = LBound(ValuesArray) To UBound(ValuesArray)

    Select Case Left(Condition2, 2)
        Case Is = "<="
            StringOperator = "<="
            Condition = Val(Mid(Condition2, 3, Len(Condition2)))
        Case Is = ">="
            StringOperator = ">="
            Condition = Val(Mid(Condition2, 3, Len(Condition2)))
        Case Is = "<>"
            StringOperator = "<>"
            If IsNumeric(Mid(Condition2, 3, Len(Condition2))) And Not IsEmpty(Condition2) Then
                Condition = Val(Mid(Condition2, 3, Len(Condition2)))
            Else
                Condition = UCase(Mid(Condition2, 3, Len(Condition2)))
            End If
        
        Case Else
            Select Case Left(Condition2, 1)
                Case Is = "<"
                    StringOperator = "<"
                    Condition = Val(Mid(Condition2, 2, Len(Condition2)))
                Case Is = ">"
                    StringOperator = ">"
                    Condition = Val(Mid(Condition2, 2, Len(Condition2)))
                Case Is = "="
                    StringOperator = "="
                    If IsNumeric(Mid(Condition2, 2, Len(Condition2))) And Not IsEmpty(Condition2) Then
                        Condition = Val(Mid(Condition2, 2, Len(Condition2)))
                    Else
                        Condition = UCase(Mid(Condition2, 2, Len(Condition2)))
                    End If
            End Select
    End Select
    Select Case StringOperator
        Case Is = ">="
            If Condition2Array(i, 1) < Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = ">"
            If Condition2Array(i, 1) <= Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = "<="
            If Condition2Array(i, 1) > Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = "<"
            If Condition2Array(i, 1) >= Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Else
            Select Case StringOperator
                Case Is = "="
                    If IsNumeric(Condition2Array(i, 1)) And Not IsEmpty(Condition2Array(i, 1)) Then
                        If Val(Condition2Array(i, 1)) <> Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    Else
                        If UCase(CStr(Condition2Array(i, 1))) <> Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    End If
                Case Is = "<>"
                    If IsNumeric(Condition2Array(i, 1)) And Not IsEmpty(Condition2Array(i, 1)) Then
                        If Val(Condition2Array(i, 1)) = Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    Else
                        If UCase(CStr(Condition2Array(i, 1))) = Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    End If
            End Select
    End Select
    
Next i
If ConditionRange3 Is Nothing Then
GoTo FinalCalc
End If

'Condition 3
For i = LBound(ValuesArray) To UBound(ValuesArray)

    Select Case Left(Condition3, 2)
        Case Is = "<="
            StringOperator = "<="
            Condition = Val(Mid(Condition3, 3, Len(Condition3)))
        Case Is = ">="
            StringOperator = ">="
            Condition = Val(Mid(Condition3, 3, Len(Condition3)))
        Case Is = "<>"
            StringOperator = "<>"
            If IsNumeric(Mid(Condition3, 3, Len(Condition3))) And Not IsEmpty(Condition3) Then
                Condition = Val(Mid(Condition3, 3, Len(Condition3)))
            Else
                Condition = UCase(Mid(Condition3, 3, Len(Condition3)))
            End If
        
        Case Else
            Select Case Left(Condition3, 1)
                Case Is = "<"
                    StringOperator = "<"
                    Condition = Val(Mid(Condition3, 2, Len(Condition3)))
                Case Is = ">"
                    StringOperator = ">"
                    Condition = Val(Mid(Condition3, 2, Len(Condition3)))
                Case Is = "="
                    StringOperator = "="
                    If IsNumeric(Mid(Condition3, 2, Len(Condition3))) And Not IsEmpty(Condition3) Then
                        Condition = Val(Mid(Condition3, 2, Len(Condition3)))
                    Else
                        Condition = UCase(Mid(Condition3, 2, Len(Condition3)))
                    End If
            End Select
    End Select
    Select Case StringOperator
        Case Is = ">="
            If Condition3Array(i, 1) < Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = ">"
            If Condition3Array(i, 1) <= Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = "<="
            If Condition3Array(i, 1) > Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Is = "<"
            If Condition3Array(i, 1) >= Condition Then
                ValuesArray(i, 1) = 0
                WeightsArray(i, 1) = 0
            End If
        Case Else
            Select Case StringOperator
                Case Is = "="
                    If IsNumeric(Condition3Array(i, 1)) And Not IsEmpty(Condition3Array(i, 1)) Then
                        If Val(Condition3Array(i, 1)) <> Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    Else
                        If UCase(CStr(Condition3Array(i, 1))) <> Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    End If
                Case Is = "<>"
                    If IsNumeric(Condition3Array(i, 1)) And Not IsEmpty(Condition3Array(i, 1)) Then
                        If Val(Condition3Array(i, 1)) = Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    Else
                        If UCase(CStr(Condition3Array(i, 1))) = Condition Then
                            ValuesArray(i, 1) = 0
                            WeightsArray(i, 1) = 0
                        End If
                    End If
            End Select
    End Select
    
Next i

FinalCalc:

dsum = Application.WorksheetFunction.Sum(WeightsArray)

For i = LBound(WeightsArray) To UBound(WeightsArray)
    WeightsArray(i, 1) = WeightsArray(i, 1) / dsum
Next i
For i = LBound(ValuesArray) To UBound(ValuesArray)
    ValuesArray(i, 1) = ValuesArray(i, 1) * WeightsArray(i, 1)
Next i

WeightedAvgIfs = Application.WorksheetFunction.Sum(ValuesArray)
End Function

Answer 1

Here's a paramarray version with some other optimizations. I did skip your IsNumeric/Empty checks but general idea is there...

'opts = 1 or more pairs of Range, Condition values
Function WeightedAvgIfs(ByVal values As Range, ByVal weights As Range, ParamArray opts()) As Double

    Dim ValuesArray(), WeightsArray(), CondArray() As Variant
    Dim i As Long, opt As Long
    Dim dsum As Double
    Dim StringOperator As String
    Dim Cond As Variant, op As String, condVal, bOK As Boolean
    
    ValuesArray = values.Value
    WeightsArray = weights.Value
    'loop over any condition range + value pairs provided
    For opt = LBound(opts) To UBound(opts) Step 2
        CondArray = opts(opt).Value          'read the criteria range values
        Cond = Trim(opts(opt + 1))           'read the criteria
        op = Left(Cond, 2)                   'extract the criteria operator
        op = IIf(op = "<=" Or op = ">=" Or op = "<>", op, Left(op, 1))
        Cond = Trim(Right(Cond, Len(Cond) - Len(op))) 'extract the criteria value
        For i = LBound(ValuesArray) To UBound(ValuesArray)
            If ValuesArray(i, 1) <> 0 And WeightsArray(i, 1) <> 0 Then 'check not already excluded
                bOK = False
                condVal = CondArray(i, 1)
                Select Case op
                    Case "<=": bOK = (condVal <= Cond)
                    Case "<": bOK = (condVal < Cond)
                    Case ">=": bOK = (condVal >= Cond)
                    Case ">": bOK = (condVal > Cond)
                    Case "=": bOK = (condVal = Cond)
                    Case "<>": bOK = (condVal <> Cond)
                End Select
                If Not bOK Then 'filtered out in this run?
                    ValuesArray(i, 1) = 0
                    WeightsArray(i, 1) = 0
                End If
            End If
        Next i
    Next opt
    
    dsum = Application.WorksheetFunction.Sum(WeightsArray)
    For i = LBound(ValuesArray) To UBound(ValuesArray)
        ValuesArray(i, 1) = ValuesArray(i, 1) * (WeightsArray(i, 1) / dsum)
    Next i
    WeightedAvgIfs = Application.WorksheetFunction.Sum(ValuesArray)
End Function