Robust UDF for finding the max less than a threshold
up vote
2
down vote
favorite
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 useSet
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 aParamArray
. This means that the tooltip (by pressingCtrl+Shift+A
after entering=MAXLESSTHANX(
in excel) producesX,number1,number2,...
which looks similar to the tooltip for Excel'sMax
. Is that overkill - should I just use theParamArray
?
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
vba
bumped to the homepage by Community♦ 7 hours ago
This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.
add a comment |
up vote
2
down vote
favorite
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 useSet
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 aParamArray
. This means that the tooltip (by pressingCtrl+Shift+A
after entering=MAXLESSTHANX(
in excel) producesX,number1,number2,...
which looks similar to the tooltip for Excel'sMax
. Is that overkill - should I just use theParamArray
?
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
vba
bumped to the homepage by Community♦ 7 hours ago
This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.
add a comment |
up vote
2
down vote
favorite
up vote
2
down vote
favorite
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 useSet
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 aParamArray
. This means that the tooltip (by pressingCtrl+Shift+A
after entering=MAXLESSTHANX(
in excel) producesX,number1,number2,...
which looks similar to the tooltip for Excel'sMax
. Is that overkill - should I just use theParamArray
?
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
vba
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 useSet
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 aParamArray
. This means that the tooltip (by pressingCtrl+Shift+A
after entering=MAXLESSTHANX(
in excel) producesX,number1,number2,...
which looks similar to the tooltip for Excel'sMax
. Is that overkill - should I just use theParamArray
?
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
vba
vba
edited Mar 21 at 22:54
Raystafarian
5,7841047
5,7841047
asked Nov 17 '17 at 18:37
bobajob
1111
1111
bumped to the homepage by Community♦ 7 hours ago
This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.
bumped to the homepage by Community♦ 7 hours ago
This question has answers that may be good or bad; the system has marked it active so that they can be reviewed.
add a comment |
add a comment |
1 Answer
1
active
oldest
votes
up vote
0
down vote
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
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.
add a comment |
1 Answer
1
active
oldest
votes
1 Answer
1
active
oldest
votes
active
oldest
votes
active
oldest
votes
up vote
0
down vote
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
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.
add a comment |
up vote
0
down vote
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
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.
add a comment |
up vote
0
down vote
up vote
0
down vote
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
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.
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
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.
edited Mar 21 at 23:15
answered Mar 21 at 23:09
Raystafarian
5,7841047
5,7841047
add a comment |
add a comment |
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
StackExchange.ready(
function () {
StackExchange.openid.initPostLogin('.new-post-login', 'https%3a%2f%2fcodereview.stackexchange.com%2fquestions%2f180699%2frobust-udf-for-finding-the-max-less-than-a-threshold%23new-answer', 'question_page');
}
);
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Sign up or log in
StackExchange.ready(function () {
StackExchange.helpers.onClickDraftSave('#login-link');
});
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Sign up using Google
Sign up using Facebook
Sign up using Email and Password
Post as a guest
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown
Required, but never shown