With regard to Rewriting the CEILING function, fzz comments:
Not only does it fail to handle arrays, it also mishandles string arguments that could be converted into numbers.
Good one. I hate it when I miss the easier ones.
Now extend it to handle array formulae!
Ouch! That complicates things. Below is my attempt at that. There’s probably a better way to combine arrays, but I couldn’t figure it out.
Public Function xCEILING(number As Variant, significance As Variant) As Variant
Dim vaNumber() As Variant
Dim vaSignif() As Variant
Dim vaTempNum() As Variant
Dim vaTempSig() As Variant
Dim lTemp As Long
Dim i As Long
Dim bDelayedCalc As Boolean
Dim vaReturn() As Variant
‘In case of error, make sure return array has at least one element
ReDim vaReturn(1 To 1)
On Error GoTo Err_Proc
‘Convert arguments into 2D arrays
vaTempNum = ConvertToArray(number)
vaTempSig = ConvertToArray(significance)
‘Send two 2D arrays and get back two 1D arrays
CombineArrays vaTempNum, vaTempSig, vaNumber, vaSignif
ReDim vaReturn(1 To UBound(vaNumber))
For i = LBound(vaNumber) To UBound(vaNumber)
bDelayedCalc = True
Select Case True
Case TypeName(vaNumber(i)) = “Error”
vaReturn(i) = vaNumber(i)
bDelayedCalc = False
Case TypeName(vaSignif(i)) = “Error”
vaReturn(i) = vaSignif(i)
bDelayedCalc = False
Case IsDate(vaNumber(i))
vaNumber(i) = CDbl(vaNumber(i))
Case IsDate(vaSignif(i))
vaSignif(i) = CDbl(vaSignif(i))
Case Not IsNumeric(vaNumber(i)) Or Not IsNumeric(vaSignif(i))
vaReturn(i) = CVErr(xlErrValue)
bDelayedCalc = False
Case TypeName(vaNumber(i)) = “Boolean”
vaNumber(i) = Abs(CDbl(vaNumber(i)))
Case TypeName(vaSignif(i)) = “Boolean”
vaSignif(i) = Abs(CDbl(vaSignif(i)))
Case (vaNumber(i) < 0) <> (vaSignif(i) < 0)
vaReturn(i) = CVErr(xlErrNum)
bDelayedCalc = False
Case vaSignif(i) = 0
vaReturn(i) = 0
bDelayedCalc = False
End Select
If bDelayedCalc Then
lTemp = Int(vaNumber(i) / vaSignif(i))
If lTemp = (vaNumber(i) / vaSignif(i)) Then ‘already at the correct precision
vaReturn(i) = vaNumber(i)
Else
vaReturn(i) = (lTemp + 1) * vaSignif(i)
End If
End If
Next i
Exit_Proc:
On Error Resume Next
xCEILING = vaReturn
Exit Function
Err_Proc:
Select Case Err.number
Case xlErrNA
vaReturn(1) = CVErr(xlErrNA)
Case Else
vaReturn(1) = CVErr(xlErrValue)
End Select
Resume Exit_Proc
End Function
Private Function ConvertToArray(vArg As Variant) As Variant
Dim vaReturn As Variant
Dim lTestArrDim As Long
Dim i As Long
Select Case TypeName(vArg)
Case “Range”
If vArg.Cells.Count = 1 Then
ReDim vaReturn(1 To 1, 1 To 1)
vaReturn(1, 1) = vArg.Value
Else
vaReturn = vArg.Value
End If
Case “Boolean”
ReDim vaReturn(1 To 1, 1 To 1)
vaReturn(1, 1) = Abs(CDbl(vArg)) ‘convert Excel Boolean to VBA Boolean
Case “Variant()”
‘If the array only has one dimension, convert it to two
lTestArrDim = 0
On Error Resume Next
lTestArrDim = UBound(vArg, 2)
On Error GoTo 0
If lTestArrDim = 0 Then
ReDim vaReturn(1 To 1, 1 To UBound(vArg))
For i = LBound(vArg) To UBound(vArg)
vaReturn(1, i) = vArg(i)
Next i
Else
vaReturn = vArg
End If
Case Else
vaReturn(1, 1) = IIf(IsNumeric(vArg), CDbl(vArg), vArg)
End Select
ConvertToArray = vaReturn
End Function
Private Sub CombineArrays(ByVal Arr1 As Variant, ByVal Arr2 As Variant, _
ByRef aReturn1 As Variant, ByRef aReturn2 As Variant)
Dim vaOne() As Variant
Dim vaTwo() As Variant
Dim lMaxRows As Long, lMaxCols As Long
Dim lMaxElems As Long
Dim lRow As Long, lCol As Long
Dim lElemCnt As Long
If lMaxRows < UBound(Arr1, 1) Then lMaxRows = UBound(Arr1, 1)
If lMaxRows < UBound(Arr2, 1) Then lMaxRows = UBound(Arr2, 1)
If lMaxCols < UBound(Arr1, 2) Then lMaxCols = UBound(Arr1, 2)
If lMaxCols < UBound(Arr2, 2) Then lMaxCols = UBound(Arr2, 2)
‘If elements > 1 do not match, pass NA back to calling procedure
If UBound(Arr1, 1) > 1 And UBound(Arr2, 1) > 1 And _
UBound(Arr1, 1) <> UBound(Arr2, 1) Then
Err.Raise xlErrNA
End If
If UBound(Arr1, 2) > 1 And UBound(Arr2, 2) > 1 And _
UBound(Arr1, 2) <> UBound(Arr2, 2) Then
Err.Raise xlErrNA
End If
lMaxElems = lMaxRows * lMaxCols
ReDim vaOne(1 To lMaxElems)
ReDim vaTwo(1 To lMaxElems)
For lRow = 1 To lMaxRows
For lCol = 1 To lMaxCols
lElemCnt = lElemCnt + 1
‘Match up columns and rows. When an array doesn’t have enough
‘columns or rows, use column 1 or row 1.
If lRow < = UBound(Arr1, 1) Then
If lCol <= UBound(Arr1, 2) Then
vaOne(lElemCnt) = Arr1(lRow, lCol)
Else
vaOne(lElemCnt) = Arr1(lRow, 1)
End If
Else
If lCol <= UBound(Arr1, 2) Then
vaOne(lElemCnt) = Arr1(1, lCol)
Else
vaOne(lElemCnt) = Arr1(1, 1)
End If
End If
If lRow <= UBound(Arr2, 1) Then
If lCol <= UBound(Arr2, 2) Then
vaTwo(lElemCnt) = Arr2(lRow, lCol)
Else
vaTwo(lElemCnt) = Arr2(lRow, 1)
End If
Else
If lCol <= UBound(Arr2, 2) Then
vaTwo(lElemCnt) = Arr2(1, lCol)
Else
vaTwo(lElemCnt) = Arr2(1, 1)
End If
End If
Next lCol
Next lRow
aReturn1 = vaOne
aReturn2 = vaTwo
End Sub
Dim vaNumber() As Variant
Dim vaSignif() As Variant
Dim vaTempNum() As Variant
Dim vaTempSig() As Variant
Dim lTemp As Long
Dim i As Long
Dim bDelayedCalc As Boolean
Dim vaReturn() As Variant
‘In case of error, make sure return array has at least one element
ReDim vaReturn(1 To 1)
On Error GoTo Err_Proc
‘Convert arguments into 2D arrays
vaTempNum = ConvertToArray(number)
vaTempSig = ConvertToArray(significance)
‘Send two 2D arrays and get back two 1D arrays
CombineArrays vaTempNum, vaTempSig, vaNumber, vaSignif
ReDim vaReturn(1 To UBound(vaNumber))
For i = LBound(vaNumber) To UBound(vaNumber)
bDelayedCalc = True
Select Case True
Case TypeName(vaNumber(i)) = “Error”
vaReturn(i) = vaNumber(i)
bDelayedCalc = False
Case TypeName(vaSignif(i)) = “Error”
vaReturn(i) = vaSignif(i)
bDelayedCalc = False
Case IsDate(vaNumber(i))
vaNumber(i) = CDbl(vaNumber(i))
Case IsDate(vaSignif(i))
vaSignif(i) = CDbl(vaSignif(i))
Case Not IsNumeric(vaNumber(i)) Or Not IsNumeric(vaSignif(i))
vaReturn(i) = CVErr(xlErrValue)
bDelayedCalc = False
Case TypeName(vaNumber(i)) = “Boolean”
vaNumber(i) = Abs(CDbl(vaNumber(i)))
Case TypeName(vaSignif(i)) = “Boolean”
vaSignif(i) = Abs(CDbl(vaSignif(i)))
Case (vaNumber(i) < 0) <> (vaSignif(i) < 0)
vaReturn(i) = CVErr(xlErrNum)
bDelayedCalc = False
Case vaSignif(i) = 0
vaReturn(i) = 0
bDelayedCalc = False
End Select
If bDelayedCalc Then
lTemp = Int(vaNumber(i) / vaSignif(i))
If lTemp = (vaNumber(i) / vaSignif(i)) Then ‘already at the correct precision
vaReturn(i) = vaNumber(i)
Else
vaReturn(i) = (lTemp + 1) * vaSignif(i)
End If
End If
Next i
Exit_Proc:
On Error Resume Next
xCEILING = vaReturn
Exit Function
Err_Proc:
Select Case Err.number
Case xlErrNA
vaReturn(1) = CVErr(xlErrNA)
Case Else
vaReturn(1) = CVErr(xlErrValue)
End Select
Resume Exit_Proc
End Function
Private Function ConvertToArray(vArg As Variant) As Variant
Dim vaReturn As Variant
Dim lTestArrDim As Long
Dim i As Long
Select Case TypeName(vArg)
Case “Range”
If vArg.Cells.Count = 1 Then
ReDim vaReturn(1 To 1, 1 To 1)
vaReturn(1, 1) = vArg.Value
Else
vaReturn = vArg.Value
End If
Case “Boolean”
ReDim vaReturn(1 To 1, 1 To 1)
vaReturn(1, 1) = Abs(CDbl(vArg)) ‘convert Excel Boolean to VBA Boolean
Case “Variant()”
‘If the array only has one dimension, convert it to two
lTestArrDim = 0
On Error Resume Next
lTestArrDim = UBound(vArg, 2)
On Error GoTo 0
If lTestArrDim = 0 Then
ReDim vaReturn(1 To 1, 1 To UBound(vArg))
For i = LBound(vArg) To UBound(vArg)
vaReturn(1, i) = vArg(i)
Next i
Else
vaReturn = vArg
End If
Case Else
vaReturn(1, 1) = IIf(IsNumeric(vArg), CDbl(vArg), vArg)
End Select
ConvertToArray = vaReturn
End Function
Private Sub CombineArrays(ByVal Arr1 As Variant, ByVal Arr2 As Variant, _
ByRef aReturn1 As Variant, ByRef aReturn2 As Variant)
Dim vaOne() As Variant
Dim vaTwo() As Variant
Dim lMaxRows As Long, lMaxCols As Long
Dim lMaxElems As Long
Dim lRow As Long, lCol As Long
Dim lElemCnt As Long
If lMaxRows < UBound(Arr1, 1) Then lMaxRows = UBound(Arr1, 1)
If lMaxRows < UBound(Arr2, 1) Then lMaxRows = UBound(Arr2, 1)
If lMaxCols < UBound(Arr1, 2) Then lMaxCols = UBound(Arr1, 2)
If lMaxCols < UBound(Arr2, 2) Then lMaxCols = UBound(Arr2, 2)
‘If elements > 1 do not match, pass NA back to calling procedure
If UBound(Arr1, 1) > 1 And UBound(Arr2, 1) > 1 And _
UBound(Arr1, 1) <> UBound(Arr2, 1) Then
Err.Raise xlErrNA
End If
If UBound(Arr1, 2) > 1 And UBound(Arr2, 2) > 1 And _
UBound(Arr1, 2) <> UBound(Arr2, 2) Then
Err.Raise xlErrNA
End If
lMaxElems = lMaxRows * lMaxCols
ReDim vaOne(1 To lMaxElems)
ReDim vaTwo(1 To lMaxElems)
For lRow = 1 To lMaxRows
For lCol = 1 To lMaxCols
lElemCnt = lElemCnt + 1
‘Match up columns and rows. When an array doesn’t have enough
‘columns or rows, use column 1 or row 1.
If lRow < = UBound(Arr1, 1) Then
If lCol <= UBound(Arr1, 2) Then
vaOne(lElemCnt) = Arr1(lRow, lCol)
Else
vaOne(lElemCnt) = Arr1(lRow, 1)
End If
Else
If lCol <= UBound(Arr1, 2) Then
vaOne(lElemCnt) = Arr1(1, lCol)
Else
vaOne(lElemCnt) = Arr1(1, 1)
End If
End If
If lRow <= UBound(Arr2, 1) Then
If lCol <= UBound(Arr2, 2) Then
vaTwo(lElemCnt) = Arr2(lRow, lCol)
Else
vaTwo(lElemCnt) = Arr2(lRow, 1)
End If
Else
If lCol <= UBound(Arr2, 2) Then
vaTwo(lElemCnt) = Arr2(1, lCol)
Else
vaTwo(lElemCnt) = Arr2(1, 1)
End If
End If
Next lCol
Next lRow
aReturn1 = vaOne
aReturn2 = vaTwo
End Sub
Update: Rob Bruce correctly points out that I wasn’t bubbling error cells up through properly. I was also returning an one-element array with an error for any error that occurred, rather than returning the complete array with the error in the proper element. As I was fixing that, I also discovered that dates weren’t working. The above code is the latest iteration and the old code is gone forever. What else did I miss?
Still ain’t there.
=CEILING({1.2;”3.4?;TRUE},{0.5,1.25})
returns
1.51.25
3.53.75
11.25
but
=xCEILING({1.2;”3.4?;TRUE},{0.5,1.25})
returns
1.51.253.53.7511.25
That is, CEILING will create a 2D array from differently oriented 1D array arguments.
FWIW, I got the following to work.
Private Function mkretval(a As Variant, b As Variant) As Variant
Dim i As Long, j As Long
Dim d1 As Long, d2 As Long
Dim retval As Variant, x As Variant
If TypeOf a Is Range Then a = a.Value
If TypeOf b Is Range Then b = b.Value
If Not IsArray(a) Then a = Array(a)
If Not IsArray(b) Then b = Array(b)
On Error Resume Next
i = UBound(a, 2) – LBound(a, 2)
If Err.number 0 Then
Err.Clear
x = 1
i = UBound(a, 1) – LBound(a, 1)
Err.Clear
End If
j = UBound(b, 2) – LBound(b, 2)
If Err.number 0 Then
x = x + 2
j = UBound(b, 1) – LBound(b, 1)
Err.Clear
End If
On Error GoTo 0
d2 = IIf(i > j, i, j) + 1
i = IIf(x Mod 2 > 0, 0, UBound(a, 1) – LBound(a, 1))
j = IIf(x > 1, 0, UBound(b, 1) – LBound(b, 1))
d1 = IIf(i > j, i, j) + 1
ReDim retval(1 To d1, 1 To d2)
x = CVErr(xlErrNA)
For i = 1 To d1
For j = 1 To d2
retval(i, j) = x
Next j
Next i
mkretval = retval
End Function
Function ceil(v As Variant, s As Variant) As Variant
Dim i As Long, j As Long, x As Variant, y As Variant
Dim vrb As Long, vcb As Long, srb As Long, scb As Long
Dim vr As Long, vc As Long, sr As Long, sc As Long
Dim rvr As Long, rvc As Long, retval As Variant
retval = mkretval(v, s)
rvr = UBound(retval, 1)
rvc = UBound(retval, 2)
On Error Resume Next
vrb = LBound(v, 1) – 1
If Err.number 0 Then
Err.Clear
vr = 0
Else
vr = UBound(v, 1) – vrb
End If
vcb = LBound(v, 2) – 1
If Err.number 0 Then
Err.Clear
vc = 0
Else
vc = UBound(v, 2) – vcb
End If
srb = LBound(s, 1) – 1
If Err.number 0 Then
Err.Clear
sr = 0
Else
sr = UBound(s, 1) – srb
End If
scb = LBound(s, 2) – 1
If Err.number 0 Then
Err.Clear
sc = 0
Else
sc = UBound(s, 2) – scb
End If
On Error GoTo 0
If vc = 0 Then
vcb = vrb
vc = vr
vr = 0
End If
If sc = 0 Then
scb = srb
sc = sr
sr = 0
End If
For i = 1 To rvr
If (vr 0 Then
x = v(vrb + IIf(vr > 1, i, 1), _
vcb + IIf(vc > 1, j, 1))
ElseIf vc > 0 Then
x = v(vcb + IIf(vc > 1, j, 1))
Else
x = v
End If
If VarType(x) = vbBoolean Then If x Then x = 1
If sr > 0 Then
y = s(srb + IIf(sr > 1, i, 1), _
scb + IIf(sc > 1, j, 1))
ElseIf sc > 0 Then
y = s(scb + IIf(sc > 1, j, 1))
Else
y = s
End If
If VarType(y) = vbBoolean Then If y Then y = 1
If IsNumeric(x) And IsNumeric(y) Then
If x * y = 0 Then
retval(i, j) = 0
Else
x = x / y
retval(i, j) = y * Int(x – (x Int(x)))
End If
ElseIf IsError(x) Then
retval(i, j) = x
ElseIf IsError(y) Then
retval(i, j) = y
Else
retval(i, j) = CVErr(xlErrValue)
End If
End If
Next j
End If
Next i
ceil = retval
End Function
My code in uncommented, but hopefully structured enough to understand.
Approach is very different though. Contrary to Dick’s code it can return a 2dim array. Plus it’s 2 times faster :)
DK> Code removed. The add-in that allows code in the comments doesn’t handle some html aspects well. I’ll post the corrected code when I receive it from KIC.
you’ll need the “worker bee” too
Dim dNum#, dSig#, dTmp#
Dim vRes
On Error GoTo errH
Select Case VarType(number) ‘+vbArray will error out.
Case vbError: vRes = number: GoTo endH
Case vbBoolean: dNum = Abs(number)
Case Else: dNum = number
End Select
Select Case VarType(significance)
Case vbError: vRes = significance: GoTo endH
Case vbBoolean: dSig = Abs(significance)
Case Else: dSig = significance
End Select
If dNum = 0 Or dSig = 0 Then
vRes = 0#
ElseIf Sgn(dNum) Sgn(dSig) Then
vRes = CVErr(xlErrNum)
Else
dTmp = dNum / dSig
vRes = (Int(dTmp) + Abs(dTmp Int(dTmp))) * dSig
End If
endH:
GetCeiling = vRes
Exit Function
errH:
vRes = CVErr(xlErrValue)
GoTo endH:
End Function
Sorry the first post is garbled. Skips a chunk of kicCeiling and continues in the helper GetCeiling. Dick can you remove the posts? I’ll mail you the correct code.
Jurgen
I rethought mine. I put the specific ceiling logic in a separate private function (f_ceil), merged mkretval into the original udf, made that a private function called iterretval with an extra argument for the name of the specific function (f_ceil in this case), so that it handles both creating the return value array and iterating through the arguments. iterretval calls f_ceil via Application.Run (who needs speed?), and a new public function ceil calls iterretval.
Function ceil(v As Variant, s As Variant) As Variant
ceil = iterretval(v, s, “f_ceil”)
End Function
Makes it simpler to write other udfs with 2 arguments since they could all rely on the common iterretval and would only need their own f_udf private function. If only VBA had references or pointers to functions.