[VBnet Sort] Pure VB: QuickSort Variations


	Visual Basic Sort Routine Library Pure VB: QuickSort Variations

Posted:	Saturday April 1, 2000
Updated:	Monday December 26, 2011

Applies to:	VB3, VB4-16, VB4-32, VB5, VB6
Developed with:	VB6, Windows NT4
OS restrictions:	None
Author:	VBnet - Randy Birch

Related:	Pure VB: Quick, Shell, Bubble and Selection Sort Performance Comparisons Pure VB: QuickSort Variations Pure VB: Sorting Date Arrays using QuickSort Pure VB: Applying and Understanding the QuickSort

Prerequisites

None.

Once the QuickSort is understood, we can look at optimizing it for differing data types. This page shows how to use the QuickSort against both a string and numeric array by creating variations on the sort to optimally handle the data types passed. In addition, the demo includes the code to sort the arrays in either ascending or descending order.

BAS Module Code

Because this code can be applied to any array in an application, its logical inclusion into a project would be as Subs declared Public in a BAS module. See Pure VB: Applying and Understanding the QuickSort for the description of the method.

Option Explicit

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Copyright ©1996-2011 VBnet/Randy Birch, All Rights Reserved.
' Some pages may also contain other copyrights by the author.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Distribution: You can freely use this code in your own
'               applications, but you may not reproduce 
'               or publish this code on any web site,
'               online service, or distribute as source 
'               on any media without express permission.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

Public Sub QuickSortNumericAscending(narray() As Long, inLow As Long, inHi As Long)

   Dim pivot As Long
   Dim tmpSwap As Long
   Dim tmpLow As Long
   Dim tmpHi  As Long
   
   tmpLow = inLow
   tmpHi = inHi
   
   pivot = narray((inLow + inHi) / 2)

   While (tmpLow <= tmpHi)
       
      While (narray(tmpLow) < pivot And tmpLow < inHi)
         tmpLow = tmpLow + 1
      Wend
   
      While (pivot < narray(tmpHi) And tmpHi > inLow)
         tmpHi = tmpHi - 1
      Wend

      If (tmpLow <= tmpHi) Then
         tmpSwap = narray(tmpLow)
         narray(tmpLow) = narray(tmpHi)
         narray(tmpHi) = tmpSwap
         tmpLow = tmpLow + 1
         tmpHi = tmpHi - 1
      End If
      
   Wend
    
   If (inLow < tmpHi) Then QuickSortNumericAscending narray(), inLow, tmpHi
   If (tmpLow < inHi) Then QuickSortNumericAscending narray(), tmpLow, inHi

End Sub


Public Sub QuickSortNumericDescending(narray() As Long, inLow As Long, inHi As Long)

   Dim pivot As Long
   Dim tmpSwap As Long
   Dim tmpLow As Long
   Dim tmpHi  As Long
   
   tmpLow = inLow
   tmpHi = inHi
   
   pivot = narray((inLow + inHi) / 2)
   
   While (tmpLow <= tmpHi)
        
      While (narray(tmpLow) > pivot And tmpLow < inHi)
         tmpLow = tmpLow + 1
      Wend
      
      While (pivot > narray(tmpHi) And tmpHi > inLow)
         tmpHi = tmpHi - 1
      Wend
      
      If (tmpLow <= tmpHi) Then
         tmpSwap = narray(tmpLow)
         narray(tmpLow) = narray(tmpHi)
         narray(tmpHi) = tmpSwap
         tmpLow = tmpLow + 1
         tmpHi = tmpHi - 1
      End If
      
   Wend
    
   If (inLow < tmpHi) Then QuickSortNumericDescending narray(), inLow, tmpHi
   If (tmpLow < inHi) Then QuickSortNumericDescending narray(), tmpLow, inHi

End Sub


Public Sub QuickSortStringsAscending(sarray() As String, inLow As Long, inHi As Long)
  
   Dim pivot As String
   Dim tmpSwap As String
   Dim tmpLow As Long
   Dim tmpHi As Long
   
   tmpLow = inLow
   tmpHi = inHi
   
   pivot = sarray((inLow + inHi) / 2)
  
   While (tmpLow <= tmpHi)
   
      While (sarray(tmpLow) < pivot And tmpLow < inHi)
         tmpLow = tmpLow + 1
      Wend
      
      While (pivot < sarray(tmpHi) And tmpHi > inLow)
         tmpHi = tmpHi - 1
      Wend
      
      If (tmpLow <= tmpHi) Then
         tmpSwap = sarray(tmpLow)
         sarray(tmpLow) = sarray(tmpHi)
         sarray(tmpHi) = tmpSwap
         tmpLow = tmpLow + 1
         tmpHi = tmpHi - 1
      End If
   
   Wend
  
   If (inLow < tmpHi) Then QuickSortStringsAscending sarray(), inLow, tmpHi
   If (tmpLow < inHi) Then QuickSortStringsAscending sarray(), tmpLow, inHi
  
End Sub


Public Sub QuickSortStringsDescending(sarray() As String, inLow As Long, inHi As Long)
  
   Dim pivot As String
   Dim tmpSwap As String
   Dim tmpLow As Long
   Dim tmpHi As Long
   
   tmpLow = inLow
   tmpHi = inHi
   
   pivot = sarray((inLow + inHi) / 2)
   
   While (tmpLow <= tmpHi)
      
      While (sarray(tmpLow) > pivot And tmpLow < inHi)
         tmpLow = tmpLow + 1
      Wend
    
      While (pivot > sarray(tmpHi) And tmpHi > inLow)
         tmpHi = tmpHi - 1
      Wend

      If (tmpLow <= tmpHi) Then
         tmpSwap = sarray(tmpLow)
         sarray(tmpLow) = sarray(tmpHi)
         sarray(tmpHi) = tmpSwap
         tmpLow = tmpLow + 1
         tmpHi = tmpHi - 1
      End If
  
   Wend
  
   If (inLow < tmpHi) Then QuickSortStringsDescending sarray(), inLow, tmpHi
   If (tmpLow < inHi) Then QuickSortStringsDescending sarray(), tmpLow, inHi
  
End Sub

Form Code

To a form add four list boxes (List1-List4) and five command buttons (Command1-Command5). Add the following code:

Option Explicit

Dim fontArray() As String
Dim numArray() As Long

Private Sub Form_Load()

   Command1.Enabled = False
   Command2.Enabled = False
   Command3.Enabled = False
   Command4.Enabled = False
   
End Sub


Private Sub Command1_Click()

   Dim x As Long
   
   QuickSortStringsAscending fontArray, LBound(fontArray), UBound(fontArray)
   
   List3.Visible = False
   List3.Clear
   
   For x = LBound(fontArray) To UBound(fontArray)
      List3.AddItem fontArray(x)
   Next
   
   List3.Visible = True
   
End Sub


Private Sub Command2_Click()

   Dim x As Long
   
   QuickSortStringsDescending fontArray, LBound(fontArray), UBound(fontArray)
   
   List3.Visible = False
   List3.Clear
   
   For x = LBound(fontArray) To UBound(fontArray)
      List3.AddItem fontArray(x)
   Next
   
   List3.Visible = True
   
End Sub


Private Sub Command3_Click()

   Dim c As Long
   
   QuickSortNumericAscending numArray, LBound(numArray), UBound(numArray)

   List4.Visible = False
   List4.Clear
   
   For c = LBound(numArray) To UBound(numArray)
      List4.AddItem numArray(c)
   Next
   
   List4.Visible = True
   
End Sub


Private Sub Command4_Click()

   Dim c As Long
   
   QuickSortNumericDescending numArray, LBound(numArray), UBound(numArray)
   
   List4.Visible = False
   List4.Clear
   
   For c = LBound(numArray) To UBound(numArray)
      List4.AddItem numArray(c)
   Next
   
   List4.Visible = True
   
End Sub


Private Sub Command5_Click()

  'create a few arrays
   Dim x As Long
   Dim y As Long
   Dim elements As Long
   
   Erase fontArray
   Erase numArray
   
   List1.Visible = False
   List2.Visible = False
   List1.Clear
   List2.Clear
   
  '----------------------------------------
  'create a string array from the system fonts
   ReDim fontArray(0 To 5000) As String 'should be enough!
   
  'add the screen fonts to the array
   For x = 0 To Screen.FontCount - 1
      fontArray(x) = Screen.Fonts(x)
   Next
   
   y = x - 1
   
  'and to make it larger, add the printer fonts to the array
   For x = 0 To Printer.FontCount - 1
      fontArray(x + y) = Printer.Fonts(x)
   Next
   
  'nuke the unused portion
   ReDim Preserve fontArray(x - 1 + y)


  '----------------------------------------
  'create numeric array of random numbers 
  elements = 5000
   
   ReDim numArray(0 To elements) As Long

   Randomize CSng(Time)

   For x = LBound(numArray) To UBound(numArray)
      numArray(x) = ((elements - 1) * Rnd + 1)
   Next x
   

  '----------------------------------------
  'show unsorted arrays in list1 & list2
   For x = LBound(fontArray) To UBound(fontArray)
      List1.AddItem fontArray(x)
   Next x
   
   For x = LBound(numArray) To UBound(numArray)
      List2.AddItem numArray(x)
   Next x

   Command1.Enabled = True
   Command2.Enabled = True
   Command3.Enabled = True
   Command4.Enabled = True
   Command5.Caption = "Reload Arrays"
   
   List1.Visible = True
   List2.Visible = True
   
End Sub

Comments

PayPal Link