Binaryworld - QuickSort - Sort Arrays using the QuickSort Algorithm ... [ VB -> Arrays ]

' 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