How do I sort a collection? How do I sort a collection? vba vba

How do I sort a collection?


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.

Performance Comparison

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) spacePublic 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 = colEnd Function

Arrays module

    Option Compare TextOption ExplicitOption Base 0Private 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) spacePublic 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 IfEnd SubPrivate 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    LoopEnd 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,zPublic Function compare(ByRef v1 As Variant, ByRef v2 As Variant) As LongEnd 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 ExplicitImplements IVariantComparatorPublic Function IVariantComparator_compare(v1 As Variant, v2 As Variant) As Long    IVariantComparator_compare = v2-v1End 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/


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 vItmEnd Sub


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 ListViewSet lv = New ListViewlv.ListItems.Add Text:="B"lv.ListItems.Add Text:="A"lv.SortKey = 0            ' sort based on each item's Textlv.SortOrder = lvwAscendinglv.Sorted = TrueMsgBox lv.ListItems(1)    ' returns "A"MsgBox lv.ListItems(2)    ' returns "B"