Does anyone know how to sort a collection in VBA?
If your collection doesn't contain objects and you only need to sort ascending, you might find this easier to understand:
Sub Sort(ByVal C As Collection)
Dim I As Long, J As Long
For I = 1 To C.Count - 1
For J = I + 1 To C.Count
If C(I) > C(J) Then Swap C, I, J
Next
Next
End Sub
'Take good care that J > I
Sub Swap(ByVal C As Collection, ByVal I As Long, ByVal J As Long)
C.Add C(J), , , I
C.Add C(I), , , J + 1
C.Remove I
C.Remove J
End Sub
I hacked this up in minutes, so this may not be the best bubble sort, but it should be easy to understand, and hence easy to modify for your own purposes.
There is no native sort for the Collection
in VBA, but since you can access items in the collection via index, you can implement a sorting algorithm to go through the collection and sort into a new collection.
Here's a HeapSort algorithm implementation for VBA/VB 6.
Here's what appears to be a BubbleSort algorithm implementation for VBA/VB6.
You could use a ListView. Although it is a UI object, you can use its functionality. It supports sorting. You can store data in Listview.ListItems
and then sort like this:
Dim lv As ListView
Set lv = New ListView
lv.ListItems.Add Text:="B"
lv.ListItems.Add Text:="A"
lv.SortKey = 0 ' sort based on each item's Text
lv.SortOrder = lvwAscending
lv.Sorted = True
MsgBox lv.ListItems(1) ' returns "A"
MsgBox lv.ListItems(2) ' returns "B"
The code below from this post uses a bubble sort
Sub SortCollection()
Dim cFruit As Collection
Dim vItm As Variant
Dim i As Long, j As Long
Dim vTemp As Variant
Set cFruit = New Collection
'fill the collection
cFruit.Add "Mango", "Mango"
cFruit.Add "Apple", "Apple"
cFruit.Add "Peach", "Peach"
cFruit.Add "Kiwi", "Kiwi"
cFruit.Add "Lime", "Lime"
'Two loops to bubble sort
For i = 1 To cFruit.Count - 1
For j = i + 1 To cFruit.Count
If cFruit(i) > cFruit(j) Then
'store the lesser item
vTemp = cFruit(j)
'remove the lesser item
cFruit.Remove j
're-add the lesser item before the
'greater Item
cFruit.Add vTemp, vTemp, i
End If
Next j
Next i
'Test it
For Each vItm In cFruit
Debug.Print vItm
Next vItm
End Sub
Late to the game... here's an implementation of the MergeSort algorithm in VBA for both Arrays and Collections. I tested the performance of this implementation against the BubbleSort implementation in the accepted answer using randomly generated strings. The chart below summarizes the results, i.e. that you should not use BubbleSort to sort a VBA collection.
You can download the source code from my GitHub Repository or just copy/paste the source code below into the appropriate modules.
For a collection col
, just call Collections.sort col
.
Collections module
'Sorts the given collection using the Arrays.MergeSort algorithm.
' O(n log(n)) time
' O(n) space
Public Sub sort(col As collection, Optional ByRef c As IVariantComparator)
Dim a() As Variant
Dim b() As Variant
a = Collections.ToArray(col)
Arrays.sort a(), c
Set col = Collections.FromArray(a())
End Sub
'Returns an array which exactly matches this collection.
' Note: This function is not safe for concurrent modification.
Public Function ToArray(col As collection) As Variant
Dim a() As Variant
ReDim a(0 To col.count)
Dim i As Long
For i = 0 To col.count - 1
a(i) = col(i + 1)
Next i
ToArray = a()
End Function
'Returns a Collection which exactly matches the given Array
' Note: This function is not safe for concurrent modification.
Public Function FromArray(a() As Variant) As collection
Dim col As collection
Set col = New collection
Dim element As Variant
For Each element In a
col.Add element
Next element
Set FromArray = col
End Function
Arrays module
Option Compare Text
Option Explicit
Option Base 0
Private Const INSERTIONSORT_THRESHOLD As Long = 7
'Sorts the array using the MergeSort algorithm (follows the Java legacyMergesort algorithm
'O(n*log(n)) time; O(n) space
Public Sub sort(ByRef a() As Variant, Optional ByRef c As IVariantComparator)
If c Is Nothing Then
MergeSort copyOf(a), a, 0, length(a), 0, Factory.newNumericComparator
Else
MergeSort copyOf(a), a, 0, length(a), 0, c
End If
End Sub
Private Sub MergeSort(ByRef src() As Variant, ByRef dest() As Variant, low As Long, high As Long, off As Long, ByRef c As IVariantComparator)
Dim length As Long
Dim destLow As Long
Dim destHigh As Long
Dim mid As Long
Dim i As Long
Dim p As Long
Dim q As Long
length = high - low
' insertion sort on small arrays
If length < INSERTIONSORT_THRESHOLD Then
i = low
Dim j As Long
Do While i < high
j = i
Do While True
If (j <= low) Then
Exit Do
End If
If (c.compare(dest(j - 1), dest(j)) <= 0) Then
Exit Do
End If
swap dest, j, j - 1
j = j - 1 'decrement j
Loop
i = i + 1 'increment i
Loop
Exit Sub
End If
'recursively sort halves of dest into src
destLow = low
destHigh = high
low = low + off
high = high + off
mid = (low + high) / 2
MergeSort dest, src, low, mid, -off, c
MergeSort dest, src, mid, high, -off, c
'if list is already sorted, we're done
If c.compare(src(mid - 1), src(mid)) <= 0 Then
copy src, low, dest, destLow, length - 1
Exit Sub
End If
'merge sorted halves into dest
i = destLow
p = low
q = mid
Do While i < destHigh
If (q >= high) Then
dest(i) = src(p)
p = p + 1
Else
'Otherwise, check if p<mid AND src(p) preceeds scr(q)
'See description of following idom at: https://stackoverflow.com/a/3245183/3795219
Select Case True
Case p >= mid, c.compare(src(p), src(q)) > 0
dest(i) = src(q)
q = q + 1
Case Else
dest(i) = src(p)
p = p + 1
End Select
End If
i = i + 1
Loop
End Sub
IVariantComparator class
Option Explicit
'The IVariantComparator provides a method, compare, that imposes a total ordering over a collection _
of variants. A class that implements IVariantComparator, called a Comparator, can be passed to the _
Arrays.sort and Collections.sort methods to precisely control the sort order of the elements.
'Compares two variants for their sort order. Returns -1 if v1 should be sorted ahead of v2; +1 if _
v2 should be sorted ahead of v1; and 0 if the two objects are of equal precedence. This function _
should exhibit several necessary behaviors: _
1.) compare(x,y)=-(compare(y,x) for all x,y _
2.) compare(x,y)>= 0 for all x,y _
3.) compare(x,y)>=0 and compare(y,z)>=0 implies compare(x,z)>0 for all x,y,z
Public Function compare(ByRef v1 As Variant, ByRef v2 As Variant) As Long
End Function
If no IVariantComparator
is provided to the sort
methods, then the natural ordering is assumed. However, if you need to define a different sort order (e.g. reverse) or if you want to sort custom objects, you can implement the IVariantComparator
interface. For example, to sort in reverse order, just create a class called CReverseComparator
with the following code:
CReverseComparator class
Option Explicit
Implements IVariantComparator
Public Function IVariantComparator_compare(v1 As Variant, v2 As Variant) As Long
IVariantComparator_compare = v2-v1
End Function
Then call the sort function as follows: Collections.sort col, New CReverseComparator
Bonus Material: For a visual comparison of the performance of different sorting algorithms check out https://www.toptal.com/developers/sorting-algorithms/
This code snippet works well, but it is in java.
To translate it you could do it like this:
Function CollectionSort(ByRef oCollection As Collection) As Long
Dim smTempItem1 As SeriesManager, smTempItem2 As SeriesManager
Dim i As Integer, j As Integer
i = 1
j = 1
On Error GoTo ErrFailed
Dim swapped As Boolean
swapped = True
Do While (swapped)
swapped = False
j = j + 1
For i = 1 To oCollection.Count - 1 - j
Set smTempItem1 = oCollection.Item(i)
Set smTempItem2 = oCollection.Item(i + 1)
If smTempItem1.Diff > smTempItem2.Diff Then
oCollection.Add smTempItem2, , i
oCollection.Add smTempItem1, , i + 1
oCollection.Remove i + 1
oCollection.Remove i + 2
swapped = True
End If
Next
Loop
Exit Function
ErrFailed:
Debug.Print "Error with CollectionSort: " & Err.Description
CollectionSort = Err.Number
On Error GoTo 0
End Function
SeriesManager is just a class that stores the difference between two values. It can really be any number value you want to sort on. This by default sorts in ascending order.
I had difficulty sorting a collection in vba without making a custom class.