' QuickSort an array of any type
' QuickSort is especially convenient with large arrays (>1,000
' items) that contains items in random order. Its performance
' quickly degrades if the array is already almost sorted. (There are
' variations of the QuickSort algorithm that work good with
' nearly-sorted arrays, though, but this routine doesn't use them.)
'
' NUMELS is the index of the last item to be sorted, and is
' useful if the array is only partially filled.
'
' Works with any kind of array, except UDTs and fixed-length
' strings, and including objects if your are sorting on their
' default property. string are sorted in case-sensitive mode.
'
' You can write faster procedures if you modify the first two lines
' to account for a specific data type, eg.
' Sub QuickSortS(arr() as Single, optional numEls as Variant,
' ' optional descending as Boolean)
' Dim value as Single, temp as Single

Sub QuickSort(arr as Variant, optional numEls as Variant, _
optional descending as Boolean)

Dim value as Variant, temp as Variant
Dim sp as Integer
Dim leftStk(32) as Long, rightStk(32) as Long
Dim leftNdx as Long, rightNdx as Long
Dim i as Long, j as Long

' account for optional arguments
If IsMissing(numEls) then numEls = UBound(arr)
' init pointers
leftNdx = LBound(arr)
rightNdx = numEls
' init stack
sp = 1
leftStk(sp) = leftNdx
rightStk(sp) = rightNdx

Do
If rightNdx > leftNdx then
value = arr(rightNdx)
i = leftNdx - 1
j = rightNdx
' find the pivot item
If descending then
Do
Do: i = i + 1: Loop Until arr(i) <= value
Do: j = j - 1: Loop Until j = leftNdx Or arr(j) >= value
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
Loop Until j <= i
else
Do
Do: i = i + 1: Loop Until arr(i) >= value
Do: j = j - 1: Loop Until j = leftNdx Or arr(j) <= value
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
Loop Until j <= i
End If
' swap found items
temp = arr(j)
arr(j) = arr(i)
arr(i) = arr(rightNdx)
arr(rightNdx) = temp
' push on the stack the pair of pointers that differ most
sp = sp + 1
If (i - leftNdx) > (rightNdx - i) then
leftStk(sp) = leftNdx
rightStk(sp) = i - 1
leftNdx = i + 1
else
leftStk(sp) = i + 1
rightStk(sp) = rightNdx
rightNdx = i - 1
End If
else
' pop a new pair of pointers off the stacks
leftNdx = leftStk(sp)
rightNdx = rightStk(sp)
sp = sp - 1
If sp = 0 then Exit Do
End If
Loop
End Sub




Iouri Boutchkine
[email protected]