Rewriting CEILING for Arrays

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.

And Stephen Bullen comments:

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

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?

Posted in Uncategorized

5 thoughts on “Rewriting CEILING for Arrays

  1. 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.

    Option Explicit

    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 &gt; j, i, j) + 1

      i = IIf(x Mod 2 &gt; 0, 0, UBound(a, 1) – LBound(a, 1))
      j = IIf(x &gt; 1, 0, UBound(b, 1) – LBound(b, 1))
      d1 = IIf(i &gt; 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 &gt; 1, i, 1), _
                      vcb + IIf(vc &gt; 1, j, 1))
              ElseIf vc &gt; 0 Then
                x = v(vcb + IIf(vc &gt; 1, j, 1))
              Else
                x = v
              End If

              If VarType(x) = vbBoolean Then If x Then x = 1

              If sr &gt; 0 Then
                y = s(srb + IIf(sr &gt; 1, i, 1), _
                      scb + IIf(sc &gt; 1, j, 1))
              ElseIf sc &gt; 0 Then
                y = s(scb + IIf(sc &gt; 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

  2. 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.

  3. you’ll need the “worker bee” too

    Private Function GetCeiling(ByVal number As Variant, ByVal significance As Variant) As Variant
      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

  4. 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

  5. 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.


Posting code? Use <pre> tags for VBA and <code> tags for inline.

Leave a Reply

Your email address will not be published.