How to sort a collection in Visual Basic using HeapSort

HeapSort is a simple and relatively fast sorting algorithm. The routine below uses the HeapSort algorithm to sort a VB collection object.

For more information about the HeapSort algorithm: NIST Dictionary of Algorithms and Data Structures, Wikipedia

Download file: HeapSortCollection.zip

' This routine uses the "heap sort" algorithm to sort a VB collection.
' It returns the sorted collection.
' Author: Christian d'Heureuse (www.source-code.biz)
Public Function SortCollection(ByVal c As Collection) As Collection
   Dim n As Long: n = c.Count
   If n = 0 Then Set SortCollection = New Collection: Exit Function
   ReDim Index(0 To n - 1) As Long                    ' allocate index array
   Dim i As Long, m As Long
   For i = 0 To n - 1: Index(i) = i + 1: Next         ' fill index array
   For i = n \ 2 - 1 To 0 Step -1                     ' generate ordered heap
      Heapify c, Index, i, n
      Next
   For m = n To 2 Step -1                             ' sort the index array
      Exchange Index, 0, m - 1                        ' move highest element to top
      Heapify c, Index, 0, m - 1
      Next
   Dim c2 As New Collection
   For i = 0 To n - 1: c2.Add c.Item(Index(i)): Next  ' fill output collection
   Set SortCollection = c2
   End Function

Private Sub Heapify(ByVal c As Collection, Index() As Long, ByVal i1 As Long, ByVal n As Long)
   ' Heap order rule: a[i] >= a[2*i+1] and a[i] >= a[2*i+2]
   Dim nDiv2 As Long: nDiv2 = n \ 2
   Dim i As Long: i = i1
   Do While i < nDiv2
      Dim k As Long: k = 2 * i + 1
      If k + 1 < n Then
         If c.Item(Index(k)) < c.Item(Index(k + 1)) Then k = k + 1
         End If
      If c.Item(Index(i)) >= c.Item(Index(k)) Then Exit Do
      Exchange Index, i, k
      i = k
      Loop
   End Sub

Private Sub Exchange(Index() As Long, ByVal i As Long, ByVal j As Long)
   Dim Temp As Long: Temp = Index(i)
   Index(i) = Index(j)
   Index(j) = Temp
   End Sub

Example for using the SortCollection function

Public Sub Example1()
   Dim c As New Collection
   c.Add "Pear"
   c.Add "Apple"
   c.Add "Cherry"
   c.Add "Prune"
   c.Add "Peach"
   Dim c2 As Collection
   Set c2 = SortCollection(c)
   Dim s
   For Each s In c2
      Debug.Print s
      Next
   End Sub

The following routines can be used to test the SortCollection routine:

' Test routine for the SortCollection routine.
' Uses random numbers to verify the sort algorithm.
Public Sub TestSortCollection()
   Debug.Print "Start"
   Dim i
   For i = 1 To 1000
      Dim c As Collection: Set c = GenerateCollectionWithRandomValues()
      Dim c2 As Collection: Set c2 = SortCollection(c)
      VerifyCollectionIsSorted c2
      Next
   Debug.Print "OK"
   End Sub

Private Function GenerateCollectionWithRandomValues() As Collection
   Dim n As Long: n = 1 + Rnd * 100
   Dim c As New Collection
   Dim i As Long
   For i = 1 To n
      c.Add CLng(Rnd * 1000)
      Next
   Set GenerateCollectionWithRandomValues = c
   End Function

Private Sub VerifyCollectionIsSorted(ByVal c As Collection)
   Dim i As Long
   For i = 1 To c.Count - 1
      If c.Item(i) > c.Item(i + 1) Then
         Err.Raise vbObjectError, , "Collection is not sorted!"
         End If
      Next
   End Sub

Author: Christian d'Heureuse (www.source-code.biz, www.inventec.ch/chdh)
License: Free / LGPL
Index