6
\$\begingroup\$

In recent months I have been trying to figure out how in the world one can mimic the functionality of Excel's New Dynamic Arrays exclusively in VBA. There are tricky ways to do this using the window's API, (see this link), and I have also found that one can utilize ADO with Querytables (see this link), which IMO, is a more stable implementation than using Win 32 timers. However, both of these require external functions/libraries, and I wanted to find another way. I knew that spooky things happen when using VBA's Evaluate function, so I started piddling around with it here and there. I had some free time over the weekend and decided that I would test a bunch different ideas using Evaluate, when all of the sudden, it happened...it worked!

What I have below is by no means the final product, nor is it pretty, but I was too excited to Not post it.

EDIT: @JonPeltier pointed out that GetDynamicArray1D was removing the last element of the array when sending it to the sheet, so I updated the ArrayToSheet1D to the following:

Private Sub ArrayToSheet1D(rngOut As Range, ByVal boolToRow As Boolean)
    'if zero Based
    If LBound(arryVariant, 1) = 0 Then
        If boolToRow Then
            '1-D Arry to 1 Row
            rngOut.Resize(1, UBound(arryVariant, 1) + 1).Value2 = _
            Application.Transpose(Application.Transpose(arryVariant))
        Else
            '1-D Arry to 1 column
            rngOut.Resize(UBound(arryVariant, 1) + 1).Value2 = _
            Application.Transpose(arryVariant)
        End If
    Else
        If boolToRow Then
            '1-D Arry to 1 Row
            rngOut.Resize(1, UBound(arryVariant, 1)).Value2 = _
            Application.Transpose(Application.Transpose(arryVariant))
        Else
            '1-D Arry to 1 column
            rngOut.Resize(UBound(arryVariant)).Value2 = _
            Application.Transpose(arryVariant)
        End If
    End If
End Sub

Everything else in the original code should stay the same.

Original Code:

Option Explicit

Private arryVariant As Variant
Private Const ERROR_SPILL As String = "#SPILL"

Public Function GetDynamicArray1D(ParamArray arrIn() As Variant) As Variant

    Dim strRangeFormulaOut As String, strRangeAddress As String

        If RngHasData(Application.Caller.Address, UBound(arrIn) + 1) Then GetDynamicArray1D = ERROR_SPILL: Exit Function

        arryVariant = CVar(arrIn)

        'Remove the first value
        arryVariant = Filter(arryVariant, arryVariant(0), False)

        strRangeAddress = Application.Caller.Offset(1, 0).Address(False, False)

        strRangeFormulaOut = "ArrayToSheet1D(" & strRangeAddress & "," & False & ")"

        Evaluate strRangeFormulaOut

    GetDynamicArray1D = arrIn(0)

End Function

Public Function SortValues(ByVal rngIn As Range, ByVal lngColIndex As Long, _
                           Optional boolAscending As Boolean = True) As Variant

    Dim strRngAddressBelow As String, strRngAddressToRight As String
    Dim varValue As Variant, arryTopRow As Variant

        If RngHasData(Application.Caller.Address, rngIn.Rows.Count) Then SortValues = ERROR_SPILL: Exit Function

        arryVariant = rngIn.Value

        QuickSortArrAscDesc arryVariant, lngColIndex, , , boolAscending

        arryTopRow = Application.Index(arryVariant, 1, 0)

        'get first value after sorting
        varValue = arryVariant(1, 1)

        arryTopRow = RemoveElementFromArray1D(arryTopRow, 1)

        arryVariant = DeleteRowFromArray(arryVariant, 1)

        strRngAddressBelow = Application.Caller.Offset(1, 0).Address(False, False)
        strRngAddressToRight = Application.Caller.Offset(0, 1).Address(False, False)

        Evaluate "ArrayToSheet2D(" & strRngAddressBelow & ")"

        arryVariant = arryTopRow

        Evaluate "ArrayToSheet1D(" & strRngAddressToRight & "," & True & ")"

    SortValues = varValue

End Function



'Helper Functions
Private Sub ArrayToSheet1D(rngOut As Range, ByVal boolToRow As Boolean)
    If boolToRow Then
        rngOut.Resize(1, UBound(arryVariant)).Value2 = Application.Transpose(Application.Transpose(arryVariant))
    Else
        rngOut.Resize(UBound(arryVariant)).Value2 = Application.Transpose(arryVariant)
    End If
End Sub


Private Sub ArrayToSheet2D(rngOut As Range)
    rngOut.Resize(UBound(arryVariant, 1), UBound(arryVariant, 2)).Value2 = arryVariant
End Sub


Private Function StripText(ByVal strIn As String) As Long
    With CreateObject("vbscript.regexp")
        .Global = True
        .Pattern = "[^\d]+"
        StripText = CLng(.Replace(strIn, vbNullString))
    End With
End Function

Private Function StripNumbers(ByVal strInPut As String, Optional ByVal strReplacementVal As String) As String
    With CreateObject("VBScript.RegExp")
        .Global = True
        .Pattern = "\d+"
        StripNumbers = .Replace(strInPut, strReplacementVal)
    End With
End Function


Private Function RemoveElementFromArray1D(ByRef arryIn As Variant, _
                                          ByVal lngIndex As Long) As Variant

    Dim i As Long, k As Long
    Dim arryOut As Variant

    ReDim arryOut(LBound(arryIn) To (UBound(arryIn, 1) - 1))

        For i = LBound(arryIn) To UBound(arryIn)
            If i <> lngIndex Then
                k = k + 1
                arryOut(k) = arryIn(i)
            End If
        Next i

    RemoveElementFromArray1D = arryOut

End Function

Private Function DeleteRowFromArray(ByRef arryIn As Variant, _
                                    ByVal lngRowIndex As Long) As Variant

    Dim i As Long, j As Long, k As Long
    Dim arryOut As Variant

    ReDim arryOut(LBound(arryIn, 1) To (UBound(arryIn, 1) - 1), _
                  LBound(arryIn, 2) To UBound(arryIn, 2))

        For i = LBound(arryIn, 1) To UBound(arryIn, 1)
            If i <> lngRowIndex Then
                k = k + 1
                For j = LBound(arryIn, 2) To UBound(arryIn, 2)
                    arryOut(k, j) = arryIn(i, j)
                Next j
            End If
        Next i

    DeleteRowFromArray = arryOut

End Function

Private Function RngHasData(ByVal strCallerAddress As String, ByVal lngRowCount As Long) As Boolean

    Dim strSpillRng As String

        If lngRowCount = 1 Then Exit Function 'don't need to check

        strSpillRng = GetSpillRange(strCallerAddress, lngRowCount)

    If Application.CountA(ActiveSheet.Range(strSpillRng)) > 0 Then RngHasData = True

End Function


Private Function GetSpillRange(ByVal strCallAddress As String, ByVal lngRowCount As Long) As String

    Dim strRangeBegin As String
    Dim lngStartRowBelow As Long, lngEndRowBelow As Long

        strRangeBegin = StripNumbers(CStr(Split(strCallAddress, ":")(0)))
        lngStartRowBelow = StripText(CStr(Split(strCallAddress, ":")(0))) + 1

            lngEndRowBelow = lngStartRowBelow + lngRowCount - 2

    GetSpillRange = strRangeBegin & CStr(lngStartRowBelow) & ":" & strRangeBegin & CStr(lngEndRowBelow)

End Function

'Adapted From Nigel Heffernan's Post 
'https://stackoverflow.com/questions/4873182/sorting-a-multidimensionnal-array-in-vba
Public Sub QuickSortArrAscDesc(ByRef arrySource As Variant, ByVal lngSortCol As Long, _
                               Optional lngMin As Long = -1, _
                               Optional lngMax As Long = -1, _
                               Optional boolAscending As Boolean = True)

 Dim varPivot As Variant, i As Long, j As Long, lngColTemp As Long
 Dim arrRowTemp As Variant

    If IsEmpty(arrySource) Then Exit Sub

    If InStr(TypeName(arrySource), "()") < 1 Then Exit Sub

    If lngMin = -1 Then lngMin = LBound(arrySource, 1)

    If lngMax = -1 Then lngMax = UBound(arrySource, 1)

    If lngMin >= lngMax Then Exit Sub

    i = lngMin
    j = lngMax

    varPivot = Empty
    varPivot = arrySource(Int((lngMin + lngMax) / 2), lngSortCol)

    Do While i <= j
        If boolAscending Then
            Do While arrySource(i, lngSortCol) < varPivot
                i = i + 1
            Loop
        Else
            Do While arrySource(i, lngSortCol) > varPivot
                i = i + 1
            Loop
        End If
        If boolAscending Then
            Do While arrySource(j, lngSortCol) > varPivot
                j = j - 1
            Loop

        Else
            Do While arrySource(j, lngSortCol) < varPivot
                j = j - 1
            Loop
        End If

        If i <= j Then
            For lngColTemp = LBound(arrySource, 2) To UBound(arrySource, 2)
                arrRowTemp = arrySource(i, lngColTemp)
                arrySource(i, lngColTemp) = arrySource(j, lngColTemp)
                arrySource(j, lngColTemp) = arrRowTemp
            Next
            arrRowTemp = Empty
            i = i + 1
            j = j - 1
         End If
    Loop

    If lngMin < j Then QuickSortArrAscDesc arrySource, lngSortCol, lngMin, j, boolAscending
    If i < lngMax Then QuickSortArrAscDesc arrySource, lngSortCol, lngMax, j, boolAscending

End Sub

SortValues Example:

enter image description here

enter image description here

GetDynamicArray1D Example:

enter image description here

enter image description here

\$\endgroup\$
  • 1
    \$\begingroup\$ While outputting a #SPILL string looks like the thing, I would recommend outputting an actual existing/supported Error type (e.g. CVErr(xlErrValue)), so that native functions like IsError still work correctly. \$\endgroup\$ – Mathieu Guindon Aug 19 at 22:34
  • \$\begingroup\$ So, IIUC, the functions return actual arrays that can be fed to array-accepting functions, correct? \$\endgroup\$ – Mathieu Guindon Aug 19 at 23:12
  • 1
    \$\begingroup\$ I can't wait to play with it, wondering if e.g. INDEX could wrap SORTVALUES =) \$\endgroup\$ – Mathieu Guindon Aug 19 at 23:42
  • 1
    \$\begingroup\$ @MathieuGuindon If this can be object oriented, while at the same time implementing more error checking procedures, looking at formula precedent and dependent relationships, etc., some really cool stuff could be done with it. \$\endgroup\$ – rickmanalexander Aug 19 at 23:57
  • 1
    \$\begingroup\$ @JonPeltier Because the array is zero-based, range.resize is cutting off the last element. See my edit for details. \$\endgroup\$ – rickmanalexander Aug 20 at 14:42
2
\$\begingroup\$

QuickSortArrAscDesc

QuickSortArrAscDesc does not work if there are repeat values. Although there are clear improvements over the original, a couple of changes are causing the partitions from combing properly.

Current

 varPivot = arrySource(Int((lngMin + lngMax) / 2), lngSortCol)

Original

 varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)

The Current code rounds of the index by surrounding it by Int(). e.g. Array(...)(1.5) returns the 3rd element where Array(...)(Int(1.5)) will return the 2nd element.

Current

If i < lngMax Then QuickSortArrAscDesc arrySource, lngSortCol, lngMax, j, boolAscending

Original

If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)

The Current code is testing i but passing j in as a parameter.

If boolAscending Then

This If ...Else clause was repeated twice which makes it difficult to compare the Ascending and Descending variations of the code. I also found that the original was easier to read because it keep the <> consistent between the i and j loops.

Refactored QuickSortArrAscDesc

Public Sub ReversibleQuickSort(ByRef arrySource As Variant, ByVal lngSortCol As Long, _
                               Optional lngMin As Long = -1, _
                               Optional lngMax As Long = -1, _
                               Optional boolAscending As Boolean = True)

 Dim varPivot As Variant, i As Long, j As Long, lngColTemp As Long
 Dim arrRowTemp As Variant

    If IsEmpty(arrySource) Then Exit Sub

    If InStr(TypeName(arrySource), "()") < 1 Then Exit Sub

    If lngMin = -1 Then lngMin = LBound(arrySource, 1)

    If lngMax = -1 Then lngMax = UBound(arrySource, 1)

    If lngMin >= lngMax Then Exit Sub

    i = lngMin
    j = lngMax

    varPivot = Empty
    varPivot = arrySource(((lngMin + lngMax) / 2), lngSortCol)

    Do While i <= j
        If boolAscending Then
            Do While arrySource(i, lngSortCol) < varPivot
                i = i + 1
            Loop
            Do While varPivot < arrySource(j, lngSortCol)
                j = j - 1
            Loop
        Else
            Do While arrySource(i, lngSortCol) > varPivot
                i = i + 1
            Loop
            Do While varPivot > arrySource(j, lngSortCol)
                j = j - 1
            Loop
        End If

        If i <= j Then
            For lngColTemp = LBound(arrySource, 2) To UBound(arrySource, 2)
                arrRowTemp = arrySource(i, lngColTemp)
                arrySource(i, lngColTemp) = arrySource(j, lngColTemp)
                arrySource(j, lngColTemp) = arrRowTemp
            Next
            arrRowTemp = Empty
            i = i + 1
            j = j - 1
         End If
    Loop

    If lngMin < j Then ReversibleQuickSort arrySource, lngSortCol, lngMin, j, boolAscending
    If i < lngMax Then ReversibleQuickSort arrySource, lngSortCol, i, lngMax, boolAscending
End Sub

Test

Test Data

Test Data

Excuse the funky test code. It isn't pretty but it was effective.

Sub TestQuickSorts()

    Dim Values
    Dim items
    Values = [A2:C9]

    Debug.Print "QuickSortArray Results"
    [G2:I9].Clear: [g2].Formula = "=SortValues(A2:C9,3)"
    items = [I2:I9]
    items = WorksheetFunction.Transpose(items)
    Debug.Print "Ascending: "; Join(items)

    [G2:I9].Clear: [g2].Formula = "=SortValues(A2:C9,3,False)"
    items = [I2:I9]
    items = WorksheetFunction.Transpose(items)
    Debug.Print "Descending: "; Join(items)

    Debug.Print vbNewLine; "ReversibleQuickSort Results"
    ReversibleQuickSort Values, 3, , , True
    items = WorksheetFunction.Index(Values, 0, 3)
    items = WorksheetFunction.Transpose(items)
    Debug.Print "Ascending: "; Join(items)

    ReversibleQuickSort Values, 3, , , False
    items = WorksheetFunction.Index(Values, 0, 3)
    items = WorksheetFunction.Transpose(items)
    Debug.Print "Descending: "; Join(items)

End Sub

Results

Immediate Window Results

\$\endgroup\$
  • \$\begingroup\$ I caught the extra If ...Else a few minutes after I after I made the first edit, and I planned to make another edit, but work projects this week have held my mind hostage, so I completely forgot, lol! Excellent catch on the pivot calculation and on the recursive calls!! \$\endgroup\$ – rickmanalexander Aug 23 at 11:23
  • 1
    \$\begingroup\$ Thank you. Nice work! I know how much a pain it is to work with Application.Caller. \$\endgroup\$ – TinMan Aug 23 at 13:49

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.