This code shows an example of sorting a 1-dimensional array using a 'heap' style algorithm.
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 Public Sub TestHeapSort() Debug.Print "Start" Dim i For i = 1 To 1 Dim Keys: Keys = GenerateArrayWithRandomValues() Dim Index: Index = HeapSort(Keys) VerifyIndexIsSorted Keys, Index Next Debug.Print "OK" End Sub
Private Function GenerateArrayWithRandomValues() Dim x As Long Dim a(0 To 10) For x = 10 To 0 Step -1 a(UBound(a) - x) = x Debug.Print x Next x 'Dim n As Long: n = 1 + Rnd * 100 'n = 5 '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 Debug.Print Keys(Index(i)) If Keys(Index(i)) > Keys(Index(i + 1)) Then Err.Raise vbObjectError, , "Index array is not sorted!" End If Next Debug.Print UBound(Index) End Sub
