Public Sub IterativeQuickSort(ByRef LongArray() As Long)
If UBound(LongArray) - LBound(LongArray) < 5 Then MiniSort LongArray, LBound(LongArray), UBound(LongArray): Exit Sub
Dim lngMid As Long
Dim lngHi As Long
Dim lngLo As Long
Dim Temp As Long
Dim Lower As Long
Dim Upper As Long
Dim Count As Long
Dim MyStack As Collection
Set MyStack = New Collection
MyStack.Add UBound(LongArray)
MyStack.Add LBound(LongArray)
Count = 2
Do Until Count = 0
Lower = MyStack(Count)
MyStack.Remove Count
Count = Count - 1
Upper = MyStack(Count)
MyStack.Remove Count
If Upper - Lower > 4 Then
Temp = 0.5 * (Upper - Lower) + Lower
lngMid = LongArray(Temp)
LongArray(Temp) = LongArray(Lower)
lngLo = Lower
lngHi = Upper
Do
Do While LongArray(lngHi) >= lngMid And lngHi > lngLo
lngHi = lngHi - 1
Loop
If lngHi = lngLo Then
LongArray(lngLo) = lngMid
Exit Do
End If
LongArray(lngLo) = LongArray(lngHi)
lngLo = lngLo + 1
Do While LongArray(lngLo) <= lngMid And lngLo < lngHi
lngLo = lngLo + 1
Loop
If lngLo = lngHi Then
LongArray(lngHi) = lngMid
Exit Do
End If
LongArray(lngHi) = LongArray(lngLo)
lngHi = lngHi - 1
Loop
If (lngLo - Lower) > (Upper - lngLo) Then
If lngLo > 1 Then
MyStack.Add lngLo - 1
MyStack.Add Lower
End If
MyStack.Add Upper
MyStack.Add lngLo + 1
Else
MyStack.Add Upper
MyStack.Add lngLo + 1
If lngLo > 1 Then
MyStack.Add lngLo - 1
MyStack.Add Lower
End If
End If
Else
MiniSort LongArray, Lower, Upper
End If
Count = MyStack.Count
Loop
Set MyStack = Nothing
End Sub
Public Sub MiniSort(ByRef LongArray() As Long, ByRef Lower As Long, ByRef Upper As Long)
Dim lngLargest As Long
Dim lngMid1 As Long
Dim lngMid2 As Long
Dim lngMid3 As Long
Select Case Upper - Lower
Case 1
If LongArray(Lower) > LongArray(Upper) Then SwapL LongArray(Lower), LongArray(Upper)
Exit Sub
Case 2
lngMid1 = Lower + 1
lngLargest = Lower
If LongArray(lngMid1) > LongArray(Lower) Then lngLargest = Lower + 1
If Not (LongArray(Upper) > LongArray(lngLargest)) Then SwapL LongArray(lngLargest), LongArray(Upper)
If LongArray(Lower) > LongArray(lngMid1) Then SwapL LongArray(Lower), LongArray(lngMid1)
Exit Sub
Case 3
lngMid1 = Lower + 1
lngMid2 = lngMid1 + 1
lngLargest = Lower
If LongArray(lngMid1) > LongArray(Lower) Then lngLargest = Lower + 1
If LongArray(lngMid2) > LongArray(lngLargest) Then lngLargest = Lower + 2
If Not (LongArray(Upper) > LongArray(lngLargest)) Then SwapL LongArray(Upper), LongArray(lngLargest)
lngLargest = Lower
If LongArray(lngMid1) > LongArray(Lower) Then lngLargest = Lower + 1
If Not (LongArray(lngMid2) > LongArray(lngLargest)) Then SwapL LongArray(lngMid2), LongArray(lngLargest)
If LongArray(lngMid1) < LongArray(Lower) Then SwapL LongArray(Lower), LongArray(lngMid1)
Exit Sub
Case 4
lngMid1 = Lower + 1
lngMid2 = lngMid1 + 1
lngMid3 = lngMid2 + 1
lngLargest = Lower
If LongArray(lngMid1) > LongArray(Lower) Then lngLargest = Lower + 1
If LongArray(lngMid2) > LongArray(lngLargest) Then lngLargest = Lower + 2
If LongArray(lngMid3) > LongArray(lngLargest) Then lngLargest = Lower + 3
If Not (LongArray(Upper) > LongArray(lngLargest)) Then SwapL LongArray(Upper), LongArray(lngLargest)
lngLargest = Lower
If LongArray(lngMid1) > LongArray(Lower) Then lngLargest = Lower + 1
If LongArray(lngMid2) > LongArray(lngLargest) Then lngLargest = Lower + 2
If Not (LongArray(lngMid3) > LongArray(lngLargest)) Then SwapL LongArray(lngMid3), LongArray(lngLargest)
lngLargest = Lower
If LongArray(lngMid1) > LongArray(Lower) Then lngLargest = Lower + 1
If Not (LongArray(lngMid2) > LongArray(lngLargest)) Then SwapL LongArray(lngMid2), LongArray(lngLargest)
If LongArray(lngMid1) < LongArray(Lower) Then SwapL LongArray(Lower), LongArray(lngMid1)
Exit Sub
End Select
End Sub
Private Sub SwapL(ByRef Num1 As Long, ByRef Num2 As Long)
Dim Temp As Long
Temp = Num1
Num1 = Num2
Num2 = Temp
End Sub