How to sort an array in Visual Basic using HeapSort

Heapsort is a simple and relatively fast sorting algorithm. The routines below can be used to generate a sorted index of the values in an array.

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

Download File: HeapSort.bas.zip

' Heap sort routine.
' Returns a sorted Index array for the Keys array.
' Author: Christian d'Heureuse (www.source-code.biz)
Public Function HeapSort(Keys)
   Dim Base As Long: Base = LBound(Keys)                    ' array index base
   Dim n As Long: n = UBound(Keys) - LBound(Keys) + 1       ' array size
   ReDim Index(Base To Base + n - 1) As Long                ' allocate index array
   Dim i As Long, m As Long
   For i = 0 To n - 1: Index(Base + i) = Base + i: Next     ' fill index array
   For i = n \ 2 - 1 To 0 Step -1                           ' generate ordered heap
      Heapify Keys, Index, i, n
      Next
   For m = n To 2 Step -1
      Exchange Index, 0, m - 1                              ' move highest element to top
      Heapify Keys, Index, 0, m - 1
      Next
   HeapSort = Index
   End Function

Private Sub Heapify(Keys, 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 Base As Long: Base = LBound(Index)
   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 Keys(Index(Base + k)) < Keys(Index(Base + k + 1)) Then k = k + 1
         End If
      If Keys(Index(Base + i)) >= Keys(Index(Base + k)) Then Exit Do
      Exchange Index, i, k
      i = k
      Loop
   End Sub

Private Sub Exchange(a() As Long, ByVal i As Long, ByVal j As Long)
   Dim Base As Long: Base = LBound(a)
   Dim Temp As Long: Temp = a(Base + i)
   a(Base + i) = a(Base + j)
   a(Base + j) = Temp
   End Sub

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

Public Sub TestHeapSort()
   Debug.Print "Start"
   Dim i
   For i = 1 To 1000
      Dim Keys: Keys = GenerateArrayWithRandomValues()
      Dim Index: Index = HeapSort(Keys)
      VerifyIndexIsSorted Keys, Index
      Next
   Debug.Print "OK"
   End Sub

Private Function GenerateArrayWithRandomValues()
   Dim n As Long: n = 1 + Rnd * 100
   ReDim a(0 To n - 1) As Long
   Dim i As Long
   For i = LBound(a) To UBound(a)
      a(i) = Rnd * 1000
      Next
   GenerateArrayWithRandomValues = a
   End Function

Private Sub VerifyIndexIsSorted(Keys, Index)
   Dim i As Long
   For i = LBound(Index) To UBound(Index) - 1
      If Keys(Index(i)) > Keys(Index(i + 1)) Then
         Err.Raise vbObjectError, , "Index array is not sorted!"
         End If
      Next
   End Sub

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