There are two parts to the source code in this issue. The first is the actual QuickSort subroutine. It should be placed in a module called basSort. The second part is a class that the QuickSort routine requires. It should be placed in a new class module called CStack.
'----------------------------------------------------------------------
'
' Module Name: basSort
' Written By: Ray Cole
' Modifications By: C&D Programming Corp.
' Create Date: 5/98
' Copyright: Copyright 1998 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
Public Sub QuickSort(ByRef arrSort As Variant, intSortCol As Integer)
Dim i As Integer
Dim j As Integer
Dim z As Integer
Dim vntCompVal As Variant
Dim vntTempVal As Variant
Dim intLeft As Integer
Dim intRight As Integer
Dim objStack As New CStack
'Initialize stack with starting positions
Call objStack.Push(LBound(arrSort), UBound(arrSort))
'Loop until there's nothing on the stack
Do While objStack.Pop(intLeft, intRight)
i = intLeft
j = intRight
vntCompVal = arrSort((intLeft + intRight) / 2, intSortCol)
Do
'Look for a value less than the partition value
Do While (arrSort(i, intSortCol) < vntCompVal) And (i < intRight)
i = i + 1
Loop
'Look for a value greater that the partition value
Do While (vntCompVal < arrSort(j, intSortCol)) And (j > intLeft)
j = j - 1
Loop
If (i <= j) Then
'Swap the values
For z = LBound(arrSort, 2) To UBound(arrSort, 2)
vntTempVal = arrSort(i, z)
arrSort(i, z) = arrSort(j, z)
arrSort(j, z) = vntTempVal
Next z
i = i + 1
j = j - 1
End If
Loop While (i <= j)
'If there's more to go on the left, push the vals
' onto the stack
If (intLeft < j) Then
Call objStack.Push(intLeft, j)
End If
'If there's more to go on the right, push the vals
' onto the stack
If (i < intRight) Then
Call objStack.Push(i, intRight)
End If
Loop
End Sub
'----------------------------------------------------------------------
'
' Class Name: CStack
' Written By: Ray Cole
' Modifications By: C&D Programming Corp.
' Create Date: 5/98
' Copyright: Copyright 1998 by C&D Programming Corp. Source
' code may not be reproduced except for use in a
' compiled executable. All rights reserved. If
' you would like to reprint any or all of this
' code please email us at info@codeoftheweek.com
'----------------------------------------------------------------------
'CStack - Object to emulate a stack
'Array to hold the stack values
Private arrStack() As Integer
'Index to the current value on the stack
Private intIdx As Integer
'Push Method - Add a value to the top of the stack
Public Sub Push(intLeft As Integer, intRight As Integer)
intIdx = intIdx + 1
ReDim Preserve arrStack(1, intIdx)
arrStack(0, intIdx) = intLeft
arrStack(1, intIdx) = intRight
End Sub
'Pop Method - Remove the top value from the stack, return false if empty
Public Function Pop(ByRef intLeft As Integer, ByRef intRight As Integer) As Boolean
If intIdx < 0 Then
Pop = False
Exit Function
End If
intLeft = arrStack(0, intIdx)
intRight = arrStack(1, intIdx)
intIdx = intIdx - 1
If intIdx < 0 Then
Erase arrStack()
intIdx = -1
Else
ReDim Preserve arrStack(1, intIdx)
End If
Pop = True
End Function
Private Sub Class_Initialize()
intIdx = -1
End Sub
Private Sub Class_Terminate()
Erase arrStack()
intIdx = -1
End Sub
'------------------------------ End Class ---------------------------------