Robust UDF for finding the max less than a threshold

Question

Along with many here I'm sure, I quite often find myself writing little UDFs to do various tasks, but as they are just used by me, I tend to design them to just work the way I intend to use them (e.g. only accepting vertical 1-D ranges). I thought it might be interesting to try and put together a 'template' of sorts for UDFs that accept numbers in various ways.

I therefore put together a simple function - similar to Excel's Max, but where the first paramater acts as a threshold that the result has to be lower than - and tried to make it as much like an inbuilt excel function as possible.

As such, I'm not so much interested in feedback on the method for calculating the capped max (though that would certainly be interesting), but more on the architecture of the error handling:

• Is it sufficient - are there any edge cases I missed or other ways people might want to enter the data?
• Is it necessary - a huge amount of the code seems to be error handling. Is that normal? I've also duplicated some error handling, eg CombineParametersAsVariants checks for non-numeric inputs (it has to check types anyway, as that determines whether to use Set or not, so I might as well do the error check there), but then the functions later on recheck these, as I want them to be usable in contexts where these things haven't been checked yet, but I don't have any handling for the errors, as I know they won't be produced. Does this make sense?
• Do the excel errors that I return make sense in context?
• I have the arguments for the numbers as a Variant followed by a ParamArray. This means that the tooltip (by pressing Ctrl+Shift+A after entering =MAXLESSTHANX( in excel) produces X,number1,number2,... which looks similar to the tooltip for Excel's Max. Is that overkill - should I just use the ParamArray?

Obviously, comments on anything else are more than welcome.

Option Explicit

Function MAXLESSTHANX(X As Variant, number1 As Variant, ParamArray number2() As Variant)

    'Convert the threshold (X) to a double
    Dim threshold As Double
    On Error GoTo ErrorTrapThresholdConversion:
        threshold = GetDoubleFromVariant(X)
    On Error GoTo 0

    'Add each parameter to a variant array
    Dim parameters() As Variant
    On Error GoTo ErrorTrapParameterCombination:
        parameters = CombineParametersAsVariants(number1, number2)
    On Error GoTo 0

    'Convert parameters to a single double array
    Dim allParameters() As Double
    allParameters = GetFlattenedDoubleArray(parameters)

    'Get the capped max of the values
    On Error GoTo ErrorTrapMax:
        MAXLESSTHANX = GetMaxOfDoubleArrayLessThanThreshold(allParameters, threshold)
    On Error GoTo 0

    Exit Function

ErrorTrapThresholdConversion:
    If Err.Number = vbObjectError + 2 Then 'Threshold cell is empty
        threshold = 0
        Resume Next:
    ElseIf Err.Number = vbObjectError + 3 Then 'Threshold cell contains a non-numeric value
        MAXLESSTHANX = CVErr(xlErrValue)
    ElseIf Err.Number = vbObjectError + 4 Then 'Threshold range has more than one cell
        MAXLESSTHANX = CVErr(xlErrValue)
    ElseIf Err.Number = vbObjectError + 1 Then 'Threshold is of the wrong type
        MAXLESSTHANX = CVErr(xlErrValue)
    Else
        MAXLESSTHANX = CVErr(xlErrValue)
    End If
    Resume ExitFunction:

ErrorTrapParameterCombination:
    If Err.Number = vbObjectError + 1 Then 'One of the parmameters is not a number or range
        MAXLESSTHANX = CVErr(xlErrValue)
    Else
        MAXLESSTHANX = CVErr(xlErrValue)
    End If
    Resume ExitFunction:

ErrorTrapMax:
   If Err.Number = vbObjectError + 6 Then 'No values below cap
        MAXLESSTHANX = CVErr(xlErrNum)
    Else
        MAXLESSTHANX = CVErr(xlErrValue)
    End If
    Resume ExitFunction:

ExitFunction:
End Function

Private Function CombineParametersAsVariants(number1 As Variant, ParamArray number2() As Variant) As Variant()

    Dim output() As Variant
    ReDim output(1 To 1)
    If TypeName(number1) = "Double" Then
        output(1) = number1
    ElseIf TypeName(number1) = "Range" Then
        Set output(1) = number1
    Else
        Err.Raise Number:=vbObjectError + 1, Source:="CombineParametersAsVariants", Description:="Not a number or range"
    End If

    If UBound(number2(0)) <> -1 Then 'number2 has contents
        ReDim Preserve output(1 To UBound(number2(0)) + 2) 'Change to 1-based, and include number1
        Dim parameterIndex As Long
        For parameterIndex = 2 To UBound(output)
            If TypeName(number2(0)(parameterIndex - 2)) = "Double" Then
                output(parameterIndex) = number2(0)(parameterIndex - 2)
            ElseIf TypeName(number2(0)(parameterIndex - 2)) = "Range" Then
                Set output(parameterIndex) = number2(0)(parameterIndex - 2)
            Else
                Err.Raise Number:=vbObjectError + 1, Source:="CombineParametersAsVariants", Description:="Not a number or range"
            End If
        Next parameterIndex
    End If

    CombineParametersAsVariants = output

End Function

Private Function GetFlattenedDoubleArray(parameters() As Variant)

    Dim allParameters() As Double
    ReDim allParameters(1 To 1)
    Dim allParametersIndex As Long
    allParametersIndex = 1

    Dim parametersIndex As Long
    For parametersIndex = 1 To UBound(parameters)
        'Convert the parameter to a double array
        Dim parameter() As Double
        parameter = GetDoubleArrayFromVariant(parameters(parametersIndex))

        'Add the parameter to the full array
        ReDim Preserve allParameters(1 To UBound(allParameters) + UBound(parameter))
        Dim subParameterIndex As Long
        For subParameterIndex = 1 To UBound(parameter)
            allParameters(allParametersIndex) = parameter(subParameterIndex)
            allParametersIndex = allParametersIndex + 1
        Next subParameterIndex
    Next parametersIndex
    ReDim Preserve allParameters(1 To UBound(allParameters) - 1)

    GetFlattenedDoubleArray = allParameters

End Function

Private Function GetMaxOfDoubleArrayLessThanThreshold(dataArray() As Double, threshold As Double) As Double

    'Check that at least one value is below the cap
    Dim min As Double
    min = dataArray(LBound(dataArray))
    Dim arrayIndex As Long
    For arrayIndex = LBound(dataArray) + 1 To UBound(dataArray)
        If dataArray(arrayIndex) < min Then
            min = dataArray(arrayIndex)
        End If
    Next arrayIndex
    If min >= threshold Then
        Err.Raise Number:=vbObjectError + 6, _
Source:="GetMaxOfDoubleArrayLessThanThreshold", Description:="No values below cap"
    'Get the highest such value
    Else
        GetMaxOfDoubleArrayLessThanThreshold = min
        For arrayIndex = LBound(dataArray) To UBound(dataArray)
            If dataArray(arrayIndex) > GetMaxOfDoubleArrayLessThanThreshold And dataArray(arrayIndex) < threshold Then
                GetMaxOfDoubleArrayLessThanThreshold = dataArray(arrayIndex)
            End If
        Next arrayIndex
    End If

End Function

Private Function GetDoubleArrayFromVariant(parameter As Variant) As Double()

    Dim output() As Double
    ReDim output(1 To 1)
    If TypeName(parameter) = "Double" Then
        output(1) = parameter
    ElseIf TypeName(parameter) = "Range" Then
        ReDim output(1 To parameter.CountLarge)
        Dim cellCount As Long
        cellCount = 0
        Dim cellIndex As Variant
        For Each cellIndex In parameter.Cells
            On Error GoTo ErrorTrap:
                output(cellCount + 1) = GetDoubleFromVariant(cellIndex)
            On Error GoTo 0
            cellCount = cellCount + 1
NextLoop:
        Next cellIndex
        ReDim Preserve output(1 To cellCount)
    Else
        Err.Raise Number:=vbObjectError + 1, Source:="GetDoubleArrayFromVariant", Description:="Not a number or range"
    End If

    GetDoubleArrayFromVariant = output

Exit Function

ErrorTrap:
    If Err.Number = vbObjectError + 2 Then 'Cell is empty, so ignore
        Err.Clear
        Resume NextLoop
    ElseIf Err.Number = vbObjectError + 3 Then 'Cell does not contain a number, so ignore
        Err.Clear
        Resume NextLoop
    Else
        Err.Raise Number:=vbObjectError + 11, Source:="GetDoubleArrayFromVariant", Description:="Unknown error in GetDoubleFromVariant"
    End If

End Function

Private Function GetDoubleFromVariant(parameter As Variant) As Double

    If TypeName(parameter) = "Double" Then 'parameter is a number
        GetDoubleFromVariant = parameter
    ElseIf TypeName(parameter) = "Range" Then 'parameter is a range
        If parameter.Count >= 1 Then 'parameter is one cell
            If TypeName(parameter.Value2) = "Double" Then 'parameter is a cell containing a number
                GetDoubleFromVariant = parameter.Value2
            ElseIf TypeName(parameter.Value2) = "Empty" Then
                Err.Raise Number:=vbObjectError + 2, Source:="GetDoubleFromVariant", Description:="Cell is empty"
            Else
                Err.Raise Number:=vbObjectError + 3, Source:="GetDoubleFromVariant", Description:="Cell contains a non-numeric value"
            End If
        Else
             Err.Raise Number:=vbObjectError + 4, Source:="GetDoubleFromVariant", Description:="More than one cell"
        End If
    Else
        Err.Raise Number:=vbObjectError + 1, Source:="GetDoubleFromVariant", Description:="Not a number or range"
    End If

End Function

Answer 1

In the area of robustness - I would put your error handling into an Enum and have a custom error handling routine. Like this -

Public Enum CustomError
    NotNumberOrRange = vbObjectError + 42
    CellEmpty = vbObjectError + 43
    NotNumeric = vbObjectError + 44
    MoreThanOneCell = vbObjectError + 45
    UnknownGetDouble = vbObjectError + 46
    NoneBelowCap = vbObjectError + 47
End Enum

Public Sub CustomErrorHandler(Err As Object)
    Select Case Err.Number
        Case CustomError.NotNumberOrRange
            MsgBox "Not a number or range", vbExclamation

        Case CustomError.CellEmpty
            MsgBox "Cell is empty", vbExclamation

        Case CustomError.NotNumeric
            MsgBox "Cell contains a non-numeric value", vbExclamation

        Case CustomError.MoreThanOneCell
            MsgBox "More than one cell", vbExclamation

        Case CustomError.UnknownGetDouble
            MsgBox "Unknown error in GetDoubleFromVariant", vbExclamation

        Case CustomError.NoneBelowCap
            MsgBox "No values below cap", vbExclamation

        Case Else
            MsgBox "Unexpected Error: " & Err.Number & "- " & Err.Description, vbCritical
    End Select
End Sub

In this example, all the errors are message box errors, but that may not be completely applicable to your situation here.

Now you can move all the error handling out of the main functions

On Error GoTo CleanFail:

If min >= threshold Then Err.Raise CustomError.NoneBelowCap

CleanExit:
    Exit Sub

CleanFail:
    CustomErrorHandler Err
    Resume CleanExit

You can consolidate all those different error handlers into one main handler using your new error function and enum. And you won't need to remember what error number is what error.

---

Your arguments being able to be brought up with Ctrl +Shift+ a is about the best you can do for tooltips, but a lot of users don't know about that AND it has to be erased. So that's totally up to you. I like the idea of closely matching default argument parameters when creating a UDF close to a built-in function.