Does anyone know how to sort a collection in VBA?
Collection is a rather wrong object for sorting.
The very point of a collection is to provide very fast access to a certain element identified by a key. How the items are stored internally should be irrelevant.
You might want to consider using arrays instead of collections if you actually need sorting.
Other than that, yes, you can sort items in a collection.
You need to take any sorting algorithm available on the Internet (you can google inplementations in basically any language) and make a minor change where a swap occurs (other changes are unnecessary as vba collections, like arrays, can be accessed with indices). To swap two items in a collection, you need to remove them both from the collection and insert them back at the right positions (using the third or the forth parameter of the Add
method).
This is a VBA implementation of the QuickSort algorithm, which is often a better alternative to MergeSort:
Public Sub QuickSortSortableObjects(colSortable As collection, Optional bSortAscending As Boolean = True, Optional iLow1, Optional iHigh1)
Dim obj1 As Object
Dim obj2 As Object
Dim clsSortable As ISortableObject, clsSortable2 As ISortableObject
Dim iLow2 As Long, iHigh2 As Long
Dim vKey As Variant
On Error GoTo PtrExit
'If not provided, sort the entire collection
If IsMissing(iLow1) Then iLow1 = 1
If IsMissing(iHigh1) Then iHigh1 = colSortable.Count
'Set new extremes to old extremes
iLow2 = iLow1
iHigh2 = iHigh1
'Get the item in middle of new extremes
Set clsSortable = colSortable.Item((iLow1 + iHigh1) \ 2)
vKey = clsSortable.vSortKey
'Loop for all the items in the collection between the extremes
Do While iLow2 < iHigh2
If bSortAscending Then
'Find the first item that is greater than the mid-Contract item
Set clsSortable = colSortable.Item(iLow2)
Do While clsSortable.vSortKey < vKey And iLow2 < iHigh1
iLow2 = iLow2 + 1
Set clsSortable = colSortable.Item(iLow2)
Loop
'Find the last item that is less than the mid-Contract item
Set clsSortable2 = colSortable.Item(iHigh2)
Do While clsSortable2.vSortKey > vKey And iHigh2 > iLow1
iHigh2 = iHigh2 - 1
Set clsSortable2 = colSortable.Item(iHigh2)
Loop
Else
'Find the first item that is less than the mid-Contract item
Set clsSortable = colSortable.Item(iLow2)
Do While clsSortable.vSortKey > vKey And iLow2 < iHigh1
iLow2 = iLow2 + 1
Set clsSortable = colSortable.Item(iLow2)
Loop
'Find the last item that is greater than the mid-Contract item
Set clsSortable2 = colSortable.Item(iHigh2)
Do While clsSortable2.vSortKey < vKey And iHigh2 > iLow1
iHigh2 = iHigh2 - 1
Set clsSortable2 = colSortable.Item(iHigh2)
Loop
End If
'If the two items are in the wrong order, swap the rows
If iLow2 < iHigh2 And clsSortable.vSortKey <> clsSortable2.vSortKey Then
Set obj1 = colSortable.Item(iLow2)
Set obj2 = colSortable.Item(iHigh2)
colSortable.Remove iHigh2
If iHigh2 <= colSortable.Count Then _
colSortable.Add obj1, Before:=iHigh2 Else colSortable.Add obj1
colSortable.Remove iLow2
If iLow2 <= colSortable.Count Then _
colSortable.Add obj2, Before:=iLow2 Else colSortable.Add obj2
End If
'If the Contracters are not together, advance to the next item
If iLow2 <= iHigh2 Then
iLow2 = iLow2 + 1
iHigh2 = iHigh2 - 1
End If
Loop
'Recurse to sort the lower half of the extremes
If iHigh2 > iLow1 Then QuickSortSortableObjects colSortable, bSortAscending, iLow1, iHigh2
'Recurse to sort the upper half of the extremes
If iLow2 < iHigh1 Then QuickSortSortableObjects colSortable, bSortAscending, iLow2, iHigh1
PtrExit:
End Sub
The objects stored in the collection must implement the ISortableObject
interface, which must be defined in your VBA project. To do that, add a class module called ISortableObject with the following code:
Public Property Get vSortKey() As Variant
End Property
This is my implementation of BubbleSort:
Public Function BubbleSort(ByRef colInput As Collection, _
Optional asc = True) As Collection
Dim temp As Variant
Dim counterA As Long
Dim counterB As Long
For counterA = 1 To colInput.Count - 1
For counterB = counterA + 1 To colInput.Count
Select Case asc
Case True:
If colInput(counterA) > colInput(counterB) Then
temp = colInput(counterB)
colInput.Remove counterB
colInput.Add temp, temp, counterA
End If
Case False:
If colInput(counterA) < colInput(counterB) Then
temp = colInput(counterB)
colInput.Remove counterB
colInput.Add temp, temp, counterA
End If
End Select
Next counterB
Next counterA
Set BubbleSort = colInput
End Function
Public Sub TestMe()
Dim myCollection As New Collection
Dim element As Variant
myCollection.Add "2342"
myCollection.Add "vityata"
myCollection.Add "na"
myCollection.Add "baba"
myCollection.Add "ti"
myCollection.Add "hvarchiloto"
myCollection.Add "stackoveflow"
myCollection.Add "beta"
myCollection.Add "zuzana"
myCollection.Add "zuzan"
myCollection.Add "2z"
myCollection.Add "alpha"
Set myCollection = BubbleSort(myCollection)
For Each element In myCollection
Debug.Print element
Next element
Debug.Print "--------------------"
Set myCollection = BubbleSort(myCollection, False)
For Each element In myCollection
Debug.Print element
Next element
End Sub
It takes the collection by reference, thus it can easily return it as a function and it has an optional parameter for Ascending and Descending sorting. The sorting returns this in the immediate window:
2342
2z
alpha
baba
beta
hvarchiloto
na
stackoveflow
ti
vityata
zuzan
zuzana
--------------------
zuzana
zuzan
vityata
ti
stackoveflow
na
hvarchiloto
beta
baba
alpha
2z
2342