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:
GetDynamicArray1D Example:
#SPILLstring looks like the thing, I would recommend outputting an actual existing/supportedErrortype (e.g.CVErr(xlErrValue)), so that native functions likeIsErrorstill work correctly. \$\endgroup\$