qsort

				
'**************************************
' Name: qsort
' Description:Want to sort 5,000 10-byte strings in about 1/10th of a second? This will do it (at least on my PII-233!). The insertion sort manages the same task in about 60 seconds (even when optimized it still took about 15 seconds on the same machine).
' By: Mike Shaffer
'
' Inputs:strList (a string array)
'
' Returns:strList (the same array - sorted)
'
' Assumes:Want to sort 5,000 10-byte strings in about 1/10th of a second? This will do it (at least on my PII-233!). The insertion sort manages the same task in about 60 seconds (even when optimized it still took about 15 seconds on the same machine).
'
'This code is copyrighted and has' limited warranties.Please see http://www.Planet-Source-Code.com/vb/scripts/ShowCode.asp?txtCodeId=897&lngWId=1'for details.'**************************************

Public Function QSort(strList() As String, lLbound As Long, lUbound As Long)
 ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::'
 '::::::'
 '::: Routine:QSort :::'
 '::: Author:Mike Shaffer (after Rod Stephens, et al.) :::'
 '::: Date: 21-May-98 :::'
 '::: Purpose:Very fast sort of a string array :::'
 '::: Passed:strListString array:::'
 '::: lLboundLower bound to sort (usually 1) :::'
 '::: lUboundUpper bound to sort (usually ubound()) :::'
 '::: Returns:strList(in sorted order):::'
 '::: Copyright: Copyright *c* 1998, Mike Shaffer :::'
 '::: ALL RIGHTS RESERVED WORLDWIDE :::'
 '::: Permission granted to use in any non-commercial:::'
 '::: product with credit where due. For free:::'
 '::: commercial license contact mshaffer@nkn.net:::'
 '::: Revisions: 22-May-98 Added and then dropped revision :::'
 '::: using CopyMemory rather than the simple swap :::'
 '::: when it was found to not provide much benefit.:::'
 '::::::'
 ':::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::'
 Dim strTemp As String
 Dim strBuffer As String
 Dim lngCurLow As Long
 Dim lngCurHigh As Long
 Dim lngCurMidpoint As Long
 
 lngCurLow = lLbound' Start current low and high at actual low/high
 lngCurHigh = lUbound
 
 If lUbound <= lLbound Then Exit Function ' Error!
 lngCurMidpoint = (lLbound + lUbound) \ 2 ' Find the approx midpoint of the array
 
 strTemp = strList(lngCurMidpoint) ' Pick as a starting point (we are making
' an assumption that the data *might* be
' in semi-sorted order already!
 
 Do While (lngCurLow <= lngCurHigh)
 Do While strList(lngCurLow) < strTemp
lngCurLow = lngCurLow + 1
If lngCurLow = lUbound Then Exit Do
 Loop
 
 Do While strTemp < strList(lngCurHigh)
lngCurHigh = lngCurHigh - 1
If lngCurHigh = lLbound Then Exit Do
 Loop
 If (lngCurLow <= lngCurHigh) Then ' if low is <= high then swap
 strBuffer = strList(lngCurLow)
 strList(lngCurLow) = strList(lngCurHigh)
 strList(lngCurHigh) = strBuffer
 '
 lngCurLow = lngCurLow + 1 ' CurLow++
 lngCurHigh = lngCurHigh - 1' CurLow--
 End If
 
 Loop
 
 If lLbound < lngCurHigh Then ' Recurse if necessary
 QSort strList(), lLbound, lngCurHigh
 End If
 
 If lngCurLow < lUbound Then' Recurse if necessary
QSort strList(), lngCurLow, lUbound
 End If
 
End Function