Excel's Dynamic Array Functions...In VBA (No Win 32)

Question

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

• Mathieu Guindon: 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.
• Mathieu Guindon: So, IIUC, the functions return actual arrays that can be fed to array-accepting functions, correct?
• Mathieu Guindon: I can't wait to play with it, wondering if e.g. INDEX could wrap SORTVALUES =)
• ARickman: @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.
• ARickman: @JonPeltier Because the array is zero-based, range.resize is cutting off the last element. See my edit for details.

Answer 1

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

• ARickman: 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!!
• TinMan: Thank you. Nice work! I know how much a pain it is to work with Application.Caller.