VBA array sort function? - arrays

I'm looking for a decent sort implementation for arrays in VBA. A Quicksort would be preferred. Or any other sort algorithm other than bubble or merge would suffice.
Please note that this is to work with MS Project 2003, so should avoid any of the Excel native functions and anything .net related.

Take a look here:
Edit: The referenced source (allexperts.com) has since closed, but here are the relevant author comments:
There are many algorithms available on the web for sorting. The most versatile and usually the quickest is the Quicksort algorithm. Below is a function for it.
Call it simply by passing an array of values (string or numeric; it doesn't matter) with the Lower Array Boundary (usually 0) and the Upper Array Boundary (i.e. UBound(myArray).)
Example: Call QuickSort(myArray, 0, UBound(myArray))
When it's done, myArray will be sorted and you can do what you want with it.
(Source: archive.org)
Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
Dim pivot As Variant
Dim tmpSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
tmpLow = inLow
tmpHi = inHi
pivot = vArray((inLow + inHi) \ 2)
While (tmpLow <= tmpHi)
While (vArray(tmpLow) < pivot And tmpLow < inHi)
tmpLow = tmpLow + 1
Wend
While (pivot < vArray(tmpHi) And tmpHi > inLow)
tmpHi = tmpHi - 1
Wend
If (tmpLow <= tmpHi) Then
tmpSwap = vArray(tmpLow)
vArray(tmpLow) = vArray(tmpHi)
vArray(tmpHi) = tmpSwap
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend
If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub
Note that this only works with single-dimensional (aka "normal"?) arrays. (There's a working multi-dimensional array QuickSort here.)

I converted the 'fast quick sort' algorithm to VBA, if anyone else wants it.
I have it optimized to run on an array of Int/Longs but it should be simple to convert it to one that works on arbitrary comparable elements.
Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
Dim M As Long, i As Long, j As Long, v As Long
M = 4
If ((r - l) > M) Then
i = (r + l) / 2
If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
If (a(l) > a(r)) Then swap a, l, r
If (a(i) > a(r)) Then swap a, i, r
j = r - 1
swap a, i, j
i = l
v = a(j)
Do
Do: i = i + 1: Loop While (a(i) < v)
Do: j = j - 1: Loop While (a(j) > v)
If (j < i) Then Exit Do
swap a, i, j
Loop
swap a, i, r - 1
QuickSort a, l, j
QuickSort a, i + 1, r
End If
End Sub
Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
Dim T As Long
T = a(i)
a(i) = a(j)
a(j) = T
End Sub
Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
Dim i As Long, j As Long, v As Long
For i = lo0 + 1 To hi0
v = a(i)
j = i
Do While j > lo0
If Not a(j - 1) > v Then Exit Do
a(j) = a(j - 1)
j = j - 1
Loop
a(j) = v
Next i
End Sub
Public Sub sort(ByRef a() As Long)
QuickSort a, LBound(a), UBound(a)
InsertionSort a, LBound(a), UBound(a)
End Sub

Dim arr As Object
Dim InputArray
'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")
'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")
'number
'InputArray = Array(6, 5, 3, 4, 2, 1)
' adding the elements in the array to array_list
For Each element In InputArray
arr.Add element
Next
'sorting happens
arr.Sort
'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.
sorted_array = arr.toarray

Explanation in German but the code is a well-tested in-place implementation:
Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
Dim P1 As Long, P2 As Long, Ref As String, TEMP As String
P1 = LB
P2 = UB
Ref = Field((P1 + P2) / 2)
Do
Do While (Field(P1) < Ref)
P1 = P1 + 1
Loop
Do While (Field(P2) > Ref)
P2 = P2 - 1
Loop
If P1 <= P2 Then
TEMP = Field(P1)
Field(P1) = Field(P2)
Field(P2) = TEMP
P1 = P1 + 1
P2 = P2 - 1
End If
Loop Until (P1 > P2)
If LB < P2 Then Call QuickSort(Field, LB, P2)
If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub
Invoked like this:
Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

Natural Number (Strings) Quick Sort
Just to pile onto the topic.
Normally, if you sort strings with numbers you'll get something like this:
Text1
Text10
Text100
Text11
Text2
Text20
But you really want it to recognize the numerical values and be sorted like
Text1
Text2
Text10
Text11
Text20
Text100
Here's how to do it...
Note:
I stole the Quick Sort from the internet a long time ago, not sure where now...
I translated the CompareNaturalNum function which was originally written in C from the internet as well.
Difference from other Q-Sorts: I don't swap the values if the BottomTemp = TopTemp
Natural Number Quick Sort
Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer
intBottomTemp = intBottom
intTopTemp = intTop
strPivot = strArray((intBottom + intTop) \ 2)
Do While (intBottomTemp <= intTopTemp)
' < comparison of the values is a descending sort
Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
intBottomTemp = intBottomTemp + 1
Loop
Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
intTopTemp = intTopTemp - 1
Loop
If intBottomTemp < intTopTemp Then
strTemp = strArray(intBottomTemp)
strArray(intBottomTemp) = strArray(intTopTemp)
strArray(intTopTemp) = strTemp
End If
If intBottomTemp <= intTopTemp Then
intBottomTemp = intBottomTemp + 1
intTopTemp = intTopTemp - 1
End If
Loop
'the function calls itself until everything is in good order
If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub
Natural Number Compare(Used in Quick Sort)
Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer
If Not (IsNull(string1) Or IsNull(string2)) Then
iPos1 = 1
iPos2 = 1
Do While iPos1 <= Len(string1)
If iPos2 > Len(string2) Then
CompareNaturalNum = 1
Exit Function
End If
If isDigit(string1, iPos1) Then
If Not isDigit(string2, iPos2) Then
CompareNaturalNum = -1
Exit Function
End If
iPosOrig1 = iPos1
iPosOrig2 = iPos2
Do While isDigit(string1, iPos1)
iPos1 = iPos1 + 1
Loop
Do While isDigit(string2, iPos2)
iPos2 = iPos2 + 1
Loop
nOffset1 = (iPos1 - iPosOrig1)
nOffset2 = (iPos2 - iPosOrig2)
n1 = Val(Mid(string1, iPosOrig1, nOffset1))
n2 = Val(Mid(string2, iPosOrig2, nOffset2))
If (n1 < n2) Then
CompareNaturalNum = -1
Exit Function
ElseIf (n1 > n2) Then
CompareNaturalNum = 1
Exit Function
End If
' front padded zeros (put 01 before 1)
If (n1 = n2) Then
If (nOffset1 > nOffset2) Then
CompareNaturalNum = -1
Exit Function
ElseIf (nOffset1 < nOffset2) Then
CompareNaturalNum = 1
Exit Function
End If
End If
ElseIf isDigit(string2, iPos2) Then
CompareNaturalNum = 1
Exit Function
Else
If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
CompareNaturalNum = -1
Exit Function
ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
CompareNaturalNum = 1
Exit Function
End If
iPos1 = iPos1 + 1
iPos2 = iPos2 + 1
End If
Loop
' Everything was the same so far, check if Len(string2) > Len(String1)
' If so, then string1 < string2
If Len(string2) > Len(string1) Then
CompareNaturalNum = -1
Exit Function
End If
Else
If IsNull(string1) And Not IsNull(string2) Then
CompareNaturalNum = -1
Exit Function
ElseIf IsNull(string1) And IsNull(string2) Then
CompareNaturalNum = 0
Exit Function
ElseIf Not IsNull(string1) And IsNull(string2) Then
CompareNaturalNum = 1
Exit Function
End If
End If
End Function
isDigit(Used in CompareNaturalNum)
Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
If pos <= Len(str) Then
iCode = Asc(Mid(str, pos, 1))
If iCode >= 48 And iCode <= 57 Then isDigit = True
End If
End Function

I posted some code in answer to a related question on StackOverflow:
Sorting a multidimensionnal array in VBA
The code samples in that thread include:
A vector array Quicksort;
A multi-column array QuickSort;
A BubbleSort.
Alain's optimised Quicksort is very shiny: I just did a basic split-and-recurse, but the code sample above has a 'gating' function that cuts down on redundant comparisons of duplicated values. On the other hand, I code for Excel, and there's a bit more in the way of defensive coding - be warned, you'll need it if your array contains the pernicious 'Empty()' variant, which will break your While... Wend comparison operators and trap your code in an infinite loop.
Note that quicksort algorthms - and any recursive algorithm - can fill the stack and crash Excel. If your array has fewer than 1024 members, I'd use a rudimentary BubbleSort.
Public Sub QuickSortArray(ByRef SortArray As Variant, _
Optional lngMin As Long = -1, _
Optional lngMax As Long = -1, _
Optional lngColumn As Long = 0)
On Error Resume Next
'Sort a 2-Dimensional array
' Sample Usage: sort arrData by the contents of column 3
'
' QuickSortArray arrData, , , 3
'
'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant
' ' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim arrRowTemp As Variant
Dim lngColTemp As Long
If IsEmpty(SortArray) Then
Exit Sub
End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name
Exit Sub
End If
If lngMin = -1 Then
lngMin = LBound(SortArray, 1)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray, 1)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list:
If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid might pick up a valid default member or property
i = lngMax
j = lngMin
ElseIf IsEmpty(varMid) Then
i = lngMax
j = lngMin
ElseIf IsNull(varMid) Then
i = lngMax
j = lngMin
ElseIf varMid = "" Then
i = lngMax
j = lngMin
ElseIf varType(varMid) = vbError Then
i = lngMax
j = lngMin
ElseIf varType(varMid) > 17 Then
i = lngMax
j = lngMin
End If
While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax
i = i + 1
Wend
While varMid < SortArray(j, lngColumn) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the rows
ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2))
For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2)
arrRowTemp(lngColTemp) = SortArray(i, lngColTemp)
SortArray(i, lngColTemp) = SortArray(j, lngColTemp)
SortArray(j, lngColTemp) = arrRowTemp(lngColTemp)
Next lngColTemp
Erase arrRowTemp
i = i + 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn)
If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)
End Sub

I wonder what would you say about this array sorting code. It's quick for implementation and does the job ... haven't tested for large arrays yet. It works for one-dimensional arrays, for multidimensional additional values re-location matrix would need to be build (with one less dimension that the initial array).
For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
eValue = eArray(AR1)
For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
If eArray(AR2) < eValue Then
eArray(AR1) = eArray(AR2)
eArray(AR2) = eValue
eValue = eArray(AR1)
End If
Next AR2
Next AR1

You didn't want an Excel-based solution but since I had the same problem today and wanted to test using other Office Applications functions I wrote the function below.
Limitations:
2-dimensional arrays;
maximum of 3 columns as sort keys;
depends on Excel;
Tested calling Excel 2010 from Visio 2010
Option Base 1
Private Function sort_array_2D_excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")
' Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library
Dim excel_application As Excel.Application
Dim excel_workbook As Excel.Workbook
Dim excel_worksheet As Excel.Worksheet
Set excel_application = CreateObject("Excel.Application")
excel_application.Visible = True
excel_application.ScreenUpdating = False
excel_application.WindowState = xlNormal
Set excel_workbook = excel_application.Workbooks.Add
excel_workbook.Activate
Set excel_worksheet = excel_workbook.Worksheets.Add
excel_worksheet.Activate
excel_worksheet.Visible = xlSheetVisible
Dim excel_range As Excel.Range
Set excel_range = excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
excel_range = array_2D
For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)
If IsNumeric(array_sortkeys(i_sortkey)) Then
sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
Set array_sortkeys(i_sortkey) = excel_worksheet.Range(sortkey_range)
Else
MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
End
End If
Next i_sortkey
For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
Select Case LCase(array_sortorders(i_sortorder))
Case "asc"
array_sortorders(i_sortorder) = XlSortOrder.xlAscending
Case "desc"
array_sortorders(i_sortorder) = XlSortOrder.xlDescending
Case Else
array_sortorders(i_sortorder) = XlSortOrder.xlAscending
End Select
Next i_sortorder
Select Case LCase(tag_header)
Case "yes"
tag_header = Excel.xlYes
Case "no"
tag_header = Excel.xlNo
Case "guess"
tag_header = Excel.xlGuess
Case Else
tag_header = Excel.xlGuess
End Select
Select Case LCase(tag_matchcase)
Case "true"
tag_matchcase = True
Case "false"
tag_matchcase = False
Case Else
tag_matchcase = False
End Select
Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
Case 1
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
Case 2
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
Case 3
Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
Case Else
MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
End
End Select
For i_row = 1 To excel_range.Rows.Count
For i_column = 1 To excel_range.Columns.Count
array_2D(i_row, i_column) = excel_range(i_row, i_column)
Next i_column
Next i_row
excel_workbook.Close False
excel_application.Quit
Set excel_worksheet = Nothing
Set excel_workbook = Nothing
Set excel_application = Nothing
sort_array_2D_excel = array_2D
End Function
This is an example on how to test the function:
Private Sub test_sort()
array_unsorted = dim_sort_array()
Call msgbox_array(array_unsorted)
array_sorted = sort_array_2D_excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")
Call msgbox_array(array_sorted)
End Sub
Private Function dim_sort_array()
Dim array_unsorted(1 To 5, 1 To 3) As String
i_row = 0
i_row = i_row + 1
array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"
i_row = i_row + 1
array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
i_row = i_row + 1
array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
i_row = i_row + 1
array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
i_row = i_row + 1
array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)
dim_sort_array = array_unsorted
End Function
Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")
msgbox_string = string_info & vbLf
For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)
msgbox_string = msgbox_string & vbLf & i_row & vbTab
For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)
msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab
Next i_column
Next i_row
MsgBox msgbox_string
End Sub
If anybody tests this using other versions of office please post here if there are any problems.

Heapsort implementation. An O(n log(n)) (both average and worst case), in place, unstable sorting algorithm.
Use with: Call HeapSort(A), where A is a one dimensional array of variants, with Option Base 1.
Sub SiftUp(A() As Variant, I As Long)
Dim K As Long, P As Long, S As Variant
K = I
While K > 1
P = K \ 2
If A(K) > A(P) Then
S = A(P): A(P) = A(K): A(K) = S
K = P
Else
Exit Sub
End If
Wend
End Sub
Sub SiftDown(A() As Variant, I As Long)
Dim K As Long, L As Long, S As Variant
K = 1
Do
L = K + K
If L > I Then Exit Sub
If L + 1 <= I Then
If A(L + 1) > A(L) Then L = L + 1
End If
If A(K) < A(L) Then
S = A(K): A(K) = A(L): A(L) = S
K = L
Else
Exit Sub
End If
Loop
End Sub
Sub HeapSort(A() As Variant)
Dim N As Long, I As Long, S As Variant
N = UBound(A)
For I = 2 To N
Call SiftUp(A, I)
Next I
For I = N To 2 Step -1
S = A(I): A(I) = A(1): A(1) = S
Call SiftDown(A, I - 1)
Next
End Sub

#Prasand Kumar, here's a complete sort routine based on Prasand's concepts:
Public Sub ArrayListSort(ByRef SortArray As Variant)
'
'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
'data-type.
'
'AUTHOR: Peter Straton
'
'CREDIT: Derived from Prasand Kumar's post at: https://stackoverflow.com/questions/152319/vba-array-sort-function
'
'*************************************************************************************************************
Static ArrayListObj As Object
Dim i As Long
Dim LBnd As Long
Dim UBnd As Long
LBnd = LBound(SortArray)
UBnd = UBound(SortArray)
'If necessary, create the ArrayList object, to be used to sort the specified array's values
If ArrayListObj Is Nothing Then
Set ArrayListObj = CreateObject("System.Collections.ArrayList")
Else
ArrayListObj.Clear 'Already allocated so just clear any old contents
End If
'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
'using a single assignment statement.)
For i = LBnd To UBnd
ArrayListObj.Add SortArray(i)
Next i
ArrayListObj.Sort 'Do the sort
'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
'statement. But the result is always zero-based so then, if necessary, adjust the resulting array to match
'its original index base.
SortArray = ArrayListObj.ToArray
If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub

Somewhat related, but I was also looking for a native excel VBA solution since advanced data structures (Dictionaries, etc.) aren't working in my environment. The following implements sorting via a binary tree in VBA:
Assumes array is populated one by one
Removes duplicates
Returns a separated string ("0|2|3|4|9") which can then be split.
I used it for returning a raw sorted enumeration of rows selected for an arbitrarily selected range
Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
If CenterType = tEMPTY Then
Center = x
CenterType = tValue
ElseIf x > Center Then
If RightType = tEMPTY Then
Right = x
RightType = tValue
ElseIf RightType = tTree Then
Right.Add x
ElseIf x <> Right Then
curLeaf = Right
Set Right = New TreeList
Right.Add curLeaf
Right.Add x
RightType = tTree
End If
ElseIf x < Center Then
If LeftType = tEMPTY Then
Left = x
LeftType = tValue
ElseIf LeftType = tTree Then
Left.Add x
ElseIf x <> Left Then
curLeaf = Left
Set Left = New TreeList
Left.Add curLeaf
Left.Add x
LeftType = tTree
End If
End If
End Sub
Public Function GetList$()
Const sep$ = "|"
If LeftType = tValue Then
LeftList$ = Left & sep
ElseIf LeftType = tTree Then
LeftList = Left.GetList & sep
End If
If RightType = tValue Then
RightList$ = sep & Right
ElseIf RightType = tTree Then
RightList = sep & Right.GetList
End If
GetList = LeftList & Center & RightList
End Function
'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")

I think my code (tested) is more "educated", assuming the simpler the better.
Option Base 1
'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
Dim check As Boolean
check = True
If IsNull(Rango) Then
check = False
End If
If check Then
Application.Volatile
Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
ReDim x(n, m)
For i = 1 To n Step 1
For j = 1 To m Step 1
x(i, j) = Application.Large(Rango, k)
k = k - 1
Next j
Next i
SORT = x
Else
Exit Function
End If
End Function

This is what I use to sort in memory - it can easily be expanded to sort an array.
Sub sortlist()
Dim xarr As Variant
Dim yarr As Variant
Dim zarr As Variant
xarr = Sheets("sheet").Range("sing col range")
ReDim yarr(1 To UBound(xarr), 1 To 1)
ReDim zarr(1 To UBound(xarr), 1 To 1)
For n = 1 To UBound(xarr)
zarr(n, 1) = 1
Next n
For n = 1 To UBound(xarr) - 1
y = zarr(n, 1)
For a = n + 1 To UBound(xarr)
If xarr(n, 1) > xarr(a, 1) Then
y = y + 1
Else
zarr(a, 1) = zarr(a, 1) + 1
End If
Next a
yarr(y, 1) = xarr(n, 1)
Next n
y = zarr(UBound(xarr), 1)
yarr(y, 1) = xarr(UBound(xarr), 1)
yrng = "A1:A" & UBound(yarr)
Sheets("sheet").Range(yrng) = yarr
End Sub

Related

Function to return an array in VBA

I am an accountant and I need to match every customer payment against the outstanding invoices every day, I found a very nice and elegant VBA code published by Michael Schwimmer in this website. https://berndplumhoff.gitbook.io/sulprobil/excel/excel-vba-solutions/accounts-receivable-problem
The code works perfect, it can automatically calculate and list the results that are added up to a specific sum. However, I would like the VBA code to returns the invoice numbers as well. The code passed an array of the values to a function for calculation and then returns the possible solution to Column E, I don't have knowledge in array so don't know how to pass the array of the invoice numbers to the function and return the results. Could anyone help? The code is as below, you can also download the excel workbook from the link I provided. Thanks in advance!
Private Sub cmbCalculate_Click()
Dim dGoal As Double
Dim dTolerance As Double
Dim dAmounts() As Double
Dim vResult As Variant
Dim m As Long
Dim n As Long
With Me
dGoal = .Range("B2")
dTolerance = .Range("C2")
ReDim dAmounts(1 To 100)
For m = 2 To 101
If (.Cells(m, 1) <> "") And (IsNumeric(.Cells(m, 1))) Then
dAmounts(m - 1) = .Cells(m, 1)
Else
ReDim Preserve dAmounts(1 To m - 1)
Exit For
End If
Next
ReDim Preserve dAmounts(1 To UBound(dAmounts) - 1)
vResult = Combinations(dAmounts, dGoal, dTolerance)
Application.ScreenUpdating = False
.Range("D3:D65536").ClearContents
.Range(.Cells(3, 4), .Cells(UBound(vResult) + 3, 4)) = vResult
Application.ScreenUpdating = True
End With
End Sub
Function Combinations( _
Elements As Variant, _
Goal As Double, _
Optional Tolerance As Double, _
Optional SoFar As Variant, _
Optional Position As Long) As Variant
Dim i As Long
Dim k As Long
Dim dCompare As Double
Dim dDummy As Double
Dim vDummy As Variant
Dim vResult As Variant
If Not IsMissing(SoFar) Then
'Sum of elements so far
For Each vDummy In SoFar
dCompare = dCompare + vDummy
Next
Else
'Start elements sorted by amount
For i = 1 To UBound(Elements)
For k = i + 1 To UBound(Elements)
If Elements(k) < Elements(i) Then
dDummy = Elements(i)
Elements(i) = Elements(k)
Elements(k) = dDummy
End If
Next
Next
Set SoFar = New Collection
End If
If Position = 0 Then Position = LBound(Elements)
For i = Position To UBound(Elements)
'Add current element
SoFar.Add Elements(i)
dCompare = dCompare + Elements(i)
If Abs(Goal - dCompare) < (0.001 + Tolerance) Then
'Goal achieved
k = 0
ReDim vResult(0 To SoFar.Count - 1, 0)
For Each vDummy In SoFar
vResult(k, 0) = vDummy
k = k + 1
Next
Combinations = vResult
Exit For
ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
'Enough room for another element
'Call recursively starting with next higher amount
vResult = Combinations(Elements, Goal, Tolerance, SoFar, i + 1)
If IsArray(vResult) Then
Combinations = vResult
Exit For
Else
SoFar.Remove SoFar.Count
dCompare = dCompare - Elements(i)
End If
Else
'Amount too high
SoFar.Remove SoFar.Count
Exit For
End If
Next 'Try next higher amount
End Function
You could probably get the invoice numbers simply with a VLOOKUP but here is a VBA solution. I have changed the values in the Sofar collection from invoice amounts to the index number for that amount. That index number then gives the corresponding invoice number from a new array InvNo.
Update - Sorted by due date
Sub cmbCalculate_Click()
Dim ws As Worksheet, dAmounts() As Double, sInvno() As String
Dim i As Long, dSum As Double
Dim dtDue() As Date
Set ws = Me
i = ws.Cells(Rows.Count, "A").End(xlUp).Row
ReDim dAmounts(1 To i - 1)
ReDim sInvno(1 To i - 1)
ReDim dtDue(1 To i - 1)
' fill array
For i = 1 To UBound(dAmounts)
dAmounts(i) = ws.Cells(i + 1, "A")
sInvno(i) = ws.Cells(i + 1, "B")
dtDue(i) = ws.Cells(i + 1, "C")
dSum = dSum + dAmounts(i)
Next
' sort array
Call BubbleSort(dAmounts, sInvno, dtDue)
Dim n: For n = LBound(dAmounts) To UBound(dAmounts): Debug.Print n, dAmounts(n), sInvno(n), dtDue(n): Next
Dim dGoal As Double, dTolerance As Double, vResult As Variant
dGoal = ws.Range("D2")
dTolerance = ws.Range("E2")
' check possible
If dGoal > dSum Then
MsgBox "Error : Total for Invoices " & Format(dSum, "#,##0.00") & _
" is less than Goal " & Format(dGoal, "#,##0.00")
Else
' solve and write to sheet
vResult = Combinations2(dAmounts, sInvno, dtDue, dGoal, dTolerance)
If IsArray(vResult) Then
With ws
.Range("F3:H" & Rows.Count).ClearContents
.Range("F3").Resize(UBound(vResult), 3) = vResult
End With
MsgBox "Done"
Else
MsgBox "Cannot find suitable combination", vbCritical
End If
End If
End Sub
Function Combinations2( _
Elements As Variant, _
Invno As Variant, _
Due As Variant, _
Goal As Double, _
Optional Tolerance As Double, _
Optional SoFar As Variant, _
Optional Position As Long) As Variant
Dim i As Long, n As Long, dCompare As Double
' summate so far
If IsMissing(SoFar) Then
Set SoFar = New Collection
Else
For i = 1 To SoFar.Count
dCompare = dCompare + Elements(SoFar(i))
Next
End If
If Position = 0 Then Position = LBound(Elements)
For i = Position To UBound(Elements)
SoFar.Add CStr(i)
dCompare = dCompare + Elements(i)
' check if target achieved
If Abs(Goal - dCompare) < (0.001 + Tolerance) Then
'Goal achieved
Dim vResult As Variant
ReDim vResult(1 To SoFar.Count, 1 To 3)
For n = 1 To SoFar.Count
vResult(n, 1) = Elements(SoFar(n))
vResult(n, 2) = Invno(SoFar(n))
vResult(n, 3) = Due(SoFar(n))
Next
Combinations2 = vResult
ElseIf dCompare < (Goal + 0.001 + Tolerance) Then
'Enough room for another element
'Call recursively starting with next higher amount
vResult = Combinations2(Elements, Invno, Due, Goal, Tolerance, SoFar, i + 1)
If IsArray(vResult) Then
Combinations2 = vResult
Exit For
Else
SoFar.Remove SoFar.Count
dCompare = dCompare - Elements(i)
End If
Else
'Amount too high
SoFar.Remove SoFar.Count
Exit For
End If
Next
End Function
Sub BubbleSort(ByRef ar1 As Variant, ByRef ar2 As Variant, ByRef ar3 As Variant)
' sort both arrays
Dim d, s, i As Long, k As Long, dt As Date
For i = 1 To UBound(ar1)
For k = i + 1 To UBound(ar1)
If (ar1(k) < ar1(i)) Or _
(ar1(k) = ar1(i) _
And ar3(k) < ar3(i)) Then
d = ar1(i)
ar1(i) = ar1(k)
ar1(k) = d
s = ar2(i)
ar2(i) = ar2(k)
ar2(k) = s
dt = ar3(i)
ar3(i) = ar3(k)
ar3(k) = dt
End If
Next
Next
End Sub
Get nth match in Index
Please refer this exceljet page for function for getting nth match which is used in index function for finding the match for the nth position given by countif function as last argument of small function. Range in the countif function need to be fixed at the first cell only. So, when we copy the formula below we get relative increment in the 'n' in case of duplicate matches. So, Index function will give the incremental nth position value.
Array CSE(Control+Shift+Enter) Formula for in F3 and copy down
=INDEX(ColEResultRangeFixed,SMALL(IF(ColAValuesRangeFixed=ColEResultCriteria,ROW(ColAValuesRangeFixed)-MIN(ROW(ColAValuesRangeFixed))+1),COUNTIF($ColAValuesRangeFixedFirst,ColEResultCriteria)))
In this case.. CSE Formula in F3 and then copy down
=INDEX($B$2:$B$11,SMALL(IF($A$2:$A$11=E3,ROW($A$2:$A$11)-MIN(ROW($A$2:$A$11))+1),COUNTIF($E$3:E3,E3)))

In Excel VBA, is there a way to extract a range of values from an array where the range of values to be extracted is dynamic?

I am trying to perform a sum calculation using a set of rolling values in an array in excel VBA where the "lookback" might differ based on an input. For a simple example, this is what I hope to achieve if the lookback is 3.
[Excel Output Example][1]
This is the code that I am testing out:
Sub testArr(Lookback As Long)
Dim MyArr As Variant, OutputArr As Variant
Dim RowsToExtract As String
Dim i As Long, k As Long, n As Long
Dim SumNum As Double
MyArr = Application.Transpose(Application.Transpose(Range(Range("A2"), Range("A2").End(xlDown))))
n = Application.CountA(MyArr)
ReDim OutputArr(1 To n)
For i = Lookback To n
For k = i - Lookback + 1 To i
RowsToExtract = RowsToExtract & k & ","
Next k
RowsToExtract = Left(RowsToExtract, Len(RowsToExtract) - 1)
OutputArr(i) = Application.Sum(Application.Index(MyArr, Array(RowsToExtract), 0))
Next i
Range(Range("B2"), Range("B2").Offset(n - 1)) = OutputArr
End Sub
However I get the error Run-Time error '13': Type mismatch.
I could do this if I use the range/offset method like:
Sub testRange(Lookback As Long)
Dim InputRg As Range
Dim i As Long, n As Long
Set InputRg = Range("A2")
n = Application.CountA(Range(InputRg, InputRg.End(xlDown)))
For i = Lookback To n - 1
Range("B2").Offset(i - 1) = Application.Sum(Range(InputRg.Offset(i - 1), InputRg.Offset(i - Lookback)))
Next i
End Sub
As the list gets enormously large and several other calculations are needed (not only sum), it takes quite long if I use range/offset method. Hence I am trying to see if using the arrays will speed things up but I am unable to slice(?) a dynamic set of values from the array. Is there a way to go about doing this?
Try this (processes 1 048 576 values in 2,4 sec.):
Option Explicit
Sub RollingSum()
Const Lookback = 7
Dim cnt, cntB, i, ssum
Dim a(), b()
With ActiveSheet
a = Intersect(.Columns(1), .UsedRange)
ReDim b(1 To UBound(a) - Lookback + 1, 1 To 1)
cntB = 1
For i = LBound(a) To UBound(a) - Lookback + 1
cnt = 1
ssum = 0
Do
If cnt > Lookback Then
b(cntB, 1) = ssum
cntB = cntB + 1
Exit Do
End If
ssum = ssum + a(i + cnt - 1, 1)
cnt = cnt + 1
Loop
Next
' output
.Range("B1:B" & UBound(b)) = b
End With
End Sub
Edit2 (universal)
Sub RollingRangeProcessing()
t = Timer
Const Lookback = 7
Dim cnt, cntB, i
Dim a(), b(), c()
With ActiveSheet
a = Intersect(.Columns(1), .UsedRange)
ReDim b(1 To UBound(a) - Lookback + 1, 1 To 1)
cntB = 1
For i = LBound(a) To UBound(a) - Lookback + 1
cnt = 1
ReDim c(1 To Lookback) 'reset array c()
Do
If cnt > Lookback Then '
With WorksheetFunction
'here use the appropriate array processing function
b(cntB, 1) = .Sum(c)
'b(cntB, 1) = .Average(c)
'b(cntB, 1) = .Median(c)
End With
cntB = cntB + 1
Exit Do
End If
c(cnt) = a(i + cnt - 1, 1)
cnt = cnt + 1
Loop
Next
' output
.Range("B1:B" & UBound(b)) = b
End With
Debug.Print "Total time to process " & UBound(a) & _
" values = " & Round(Timer - t, 1) & " sec."
End Sub
Output:
Total time to process 1048576 values = 6,5 sec.

Populate one dimensional array without looping

The following line of code will allocate an array as one dimensional sortedArr = WorksheetFunction.Transpose(lstIssues1.List). This line of code allocates an array as two dimensional arrIssues = Table.ListColumns(Table.ListColumns(strNumber).Range.column).DataBodyRange
For each of the above lines I call a bubble sort function. But it errors on one or the other depending on whether I put
If Arr(i) > Arr(j) Then ...
Or
If Arr(i, 1) > Arr(j, 1) Then ...
I can loop to fill arrIssues. But I am wondering if it's possible to fill it as a one dimensional array without looping.
UPDATE
Here is the code I am having trouble with
Private Sub cmdRemove_Click()
Dim SortedArr() As Variant
With lstPrevious
If .ListIndex = -1 Then Exit Sub
For i = .ListCount - 1 To 0 Step -1
If .Selected(i) = True Then
lstAdditional.AddItem .List(i)
.RemoveItem (i)
End If
Next i
End With
ReDim SortedArr(lstAdditional.ListCount - 1)
SortedArr = Application.Transpose(lstAdditional.List) 'ERROR Type Mismatch
Call BubbleSort(SortedArr)
Me.lstAdditional.List = SortedArr
txtFocus.SetFocus
End Sub
Public Sub BubbleSort(Arr)
Dim strTemp As String
Dim lngMin As Long
Dim lngMax As Long
lngMin = LBound(Arr)
lngMax = UBound(Arr)
For i = lngMin To lngMax
For j = i + 1 To lngMax
If Arr(i) > Arr(j) Then
strTemp = Arr(i)
Arr(i) = Arr(j)
Arr(j) = strTemp
End If
Next j
Next i
End Sub
Strangely, I use the same logic in another userform and it works. Sorry for the lack of clarity.
For each of the above lines I call a bubble sort function. But it errors on one or the other depending on whether I put If Arr(i) > Arr(j) Then ... Or If Arr(i, 1) > Arr(j, 1) Then ...
Your values of i, j are incorrect and hence it errors out. I am guessing that you are getting Subscript out of range error.
Here is a simple way to reproduce the error that you are getting.
Sub Sample()
Dim i As Long, j As Long, k As Integer
Dim MyAr As Variant
MyAr = Range("A1:A5").Value
For i = LBound(MyAr) To UBound(MyAr)
For j = LBound(MyAr) To UBound(MyAr)
If MyAr(j, 1) > MyAr(j + 1, 1) Then
k = MyAr(j, 1)
MyAr(j, 1) = MyAr(j + 1, 1)
MyAr(j + 1, 1) = k
End If
Next
Next
End Sub
The correct way is to loop till UBound(MyAr) - 1
Sub Sample()
Dim i As Long, j As Long, k As Integer
Dim MyAr As Variant
MyAr = Range("A1:A5").Value
For i = LBound(MyAr) To (UBound(MyAr) - 1)
For j = LBound(MyAr) To (UBound(MyAr) - 1)
If MyAr(j, 1) > MyAr(j + 1, 1) Then
k = MyAr(j, 1)
MyAr(j, 1) = MyAr(j + 1, 1)
MyAr(j + 1, 1) = k
End If
Next
Next
End Sub

is it possbile to create an collection of arrays in vba?

first of all, i'd like to say, i've sarched thorugh the net, but i haven't run into such a thing. i've seen collection of collections, or array of arrays, but not a collection of array.
what i want to do is, to collect ID's in collections for each District. Finally, i will join the values in the collections with Join function and ";" as delimiter, and then print them in a range of 4 column as a lookup list, for each class. For example;
Class2(0) will include 54020 and 30734, class2(1) will include 58618, class1(4) will include none, class3(7) will include 35516,34781 and 56874, and so on.
i want to loop through column C and put a select case statment to check the class and then assign the values to collections
Sub dict_coll()
Dim class1() As New Collection
Dim class2() As New Collection
Dim class3() As New Collection
Dim class4() As New Collection
Dim dict As New Scripting.Dictionary
Set dRange = range(range("a2"), range("a2").End(xlDown))
i = 0
For Each d In dRange
If Not dict.Exists(d.Value) Then
dict.Add key:=d.Value, item:=i
i = i + 1
End If
Next d
Set cRange = range(range("c2"), range("c2").End(xlDown))
For Each c In cRange
Select Case c.Value
Case "class1"
class1(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class2"
class2(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case "class3"
class3(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
Case Else
class4(dict(c.offset(0,-2).value)).Add c.Offset(0, 1).Value 'fails here
End Select
Next c
End Sub
and what i want to see is as foloowing:
is there any easier and proper way of what i wanna do? any help wil be appreciated.
thanks
I didnt see that sb variable defined in your code.
Anyway, for me I see a case of straightforward arrays: There is fixed dimension of classes so it good enough for me. Furthermore, you can print back to worksheet so easily.
Public Sub test()
Const strPrefix = "class"
Dim districtRange As Range, outputRange As Range, r As Range
Dim arr() As String
Dim i As Long, j As Long, x As Long, y As Long
Dim district As String, str As String, idVal As String
Dim arr2 As Variant
Application.ScreenUpdating = False
ReDim arr(1 To 5, 1 To 1)
arr(1, 1) = "District"
arr(2, 1) = "Class 1"
arr(3, 1) = "Class 2"
arr(4, 1) = "Class 3"
arr(5, 1) = "Class 4"
Set districtRange = Range(Range("A2"), Range("C2").End(xlDown))
arr2 = districtRange.Value
For x = LBound(arr2, 1) To UBound(arr2, 1)
district = arr2(x, 1)
i = Val(Mid(arr2(x, 3), Len(strPrefix) + 1))
idVal = arr2(x, 2)
j = inArray(arr, district, 1) 'returns -1 if not found
If j >= 0 Then
arr(i + 1, j) = IIf(arr(i + 1, j) = "", idVal, arr(i + 1, j) & ";" & idVal)
Else
ReDim Preserve arr(1 To 5, 1 To UBound(arr, 2) + 1)
arr(1, UBound(arr, 2)) = district
arr(i + 1, UBound(arr, 2)) = idVal
End If
Next x
Set outputRange = Range("E1")
outputRange.Resize(UBound(arr, 2), UBound(arr, 1)).Value = Application.Transpose(arr)
outputRange.Sort Key1:=Range("E1"), Header:=xlYes, Order1:=xlAscending
Application.ScreenUpdating = True
End Sub
Public Function inArray(arr As Variant, k As String, Optional rowNum As Long, Optional colNum As Long) As Long
Dim i As Long, j As Long
inArray = -1
If rowNum Then
For i = LBound(arr, 2) To UBound(arr, 2)
If arr(rowNum, i) = k Then
inArray = i
Exit Function
End If
Next i
Else
For i = LBound(arr, 1) To UBound(arr, 1)
If arr(i, colNum) = k Then
inArray = i
Exit Function
End If
Next i
End If
End Function
by the way, i've found another solution, usinf both dictionary and 3-dimension array.
Sub test()
Dim Blg As New Scripting.Dictionary
Dim Sgm As New Scripting.Dictionary
Dim Siciller() As String
ReDim Siciller(0 To 23, 0 To 3, 0 To 5)
Set alanBolge = range(range("a2"), range("a2").End(xlDown))
Set alanSegment = range(range("c2"), range("c2").End(xlDown))
i = 0
For Each d In alanBolge
If Not Blg.Exists(d.Value) Then
Blg.Add Key:=d.Value, item:=i
i = i + 1
End If
Next d
k = 0
For Each d In alanSegment
If Not Sgm.Exists(d.Value) Then
Sgm.Add Key:=d.Value, item:=k
k = k + 1
End If
Next d
'data reading
For Each d In alanBolge
Siciller(Blg(d.Value), Sgm(d.Offset(0, 2).Value), dolusay(Siciller, Blg(d.Value), Sgm(d.Offset(0, 2).Value)) + 1) = d.Offset(0, 1).Value
Next d
'output
For x = 1 To 4
For y = 1 To 24
Set h = Cells(1 + y, 5 + x)
h.Select
h.Value = sonucgetir(Siciller, Blg(h.Offset(0, -x).Value), Sgm(h.Offset(-y, 0).Value))
Next y
Next x
End Sub
Public Function dolusay(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As Integer
Dim count As Integer
count = 0
For j = 0 To UBound(data, 3) - 1
If Len(data(i1, i2, j)) > 0 Then
count = count + 1
End If
Next
dolusay = count
End Function
Public Function sonucgetir(ByVal data As Variant, ByVal i1 As Integer, ByVal i2 As Integer) As String
sonucgetir = ""
For i = 0 To UBound(data, 3)
If Len(data(i1, i2, i)) > 0 Then
x = data(i1, i2, i) & ";" & x
sonucgetir = Left(x, Len(x) - 1)
End If
Next i
End Function

Delete Row from Array

I am trying to go through an array to find duplicate entries in a single column of that array and delete the entire row.
I am getting figuring out rangeStart, rangeEnd, and lastrow above this and that part is working fine.
data = Range(rangeStart, rangeEnd)
For i = lastrow - 1 To 2 Step -1
If data(i - 1, x) = data(i, x) Then
'Delete data(i)
End If
Next
Any help with this would be awesome!
Sub RemoveDups()
Const COMPARE_COL as Long = 1
Dim a, aNew(), nr As Long, nc As Long
Dim r As Long, c As Long, rNew As Long
Dim v As String, tmp
a = Selection.Value
nr = UBound(a, 1)
nc = UBound(a, 2)
ReDim aNew(1 To nr, 1 To nc)
rNew = 0
v = Chr(0)
For r = 1 To nr
tmp = a(r, COMPARE_COL)
If tmp <> v Then
rNew = rNew + 1
For c = 1 To nc
aNew(rNew, c) = a(r, c)
Next c
v = tmp
End If
Next r
Selection.Value = aNew
End Sub
Does this help?:
If data(i - 1, x) = data(i, x) Then
data(i,x).EntireRow.Delete
End If
Why not use Excel's inbuilt Unique options (Data ... Remove Duplicates)?
Another efficient VBA method is to use a Dictionary.
Sub A_Unique_B()
Dim X
Dim objDict As Object
Dim lngRow As Long
Set objDict = CreateObject("Scripting.Dictionary")
X = Application.Transpose(Range([a1], Cells(Rows.Count, "A").End(xlUp)))
For lngRow = 1 To UBound(X, 1)
objDict(X(lngRow)) = 1
Next
Range("B1:B" & objDict.Count) = Application.Transpose(objDict.Keys)
End Sub

Resources