How to sort an array in Visual Basic (VBasic/VB/VBA) using HeapSort

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