Quicksort code

[gk039]

Hi all,

I am trying to implement quick-sort code in vba. Everything seems to work fine until when i am calling the recursive procedures for partitioning the master array into smaller chunks. I can't retrieve correctly the new boundaries for the sub-arrays. Variable "newlngRight" is not returned with the correct value.Any help will be much appreciated.

I use a main procedure to create the array (Load_Integers(varArray() As Long, length)) where values from range A1 to A6 are passed to the array (for testing purposes) and then code is as follows:



Option Explicit
Option Base 1
Public ComparisonCounter As Long
Public left As Long, right As Long
Public newlngRight As Long, i As Long, j As Long


Sub PartitionQuickSort(varArray() As Long, lngLeft As Long, lngRight As Long)
'Declare pivot. Here is the first element of the array
Dim pivot As Long

pivot = varArray(lngLeft)
'i and j start from the position pivot + 1
i = 2
j = 2


For j = j To lngRight

If varArray(j) < pivot Then
SwapItems varArray(), i, j
i = i + 1
End If

Next j

'Bring pivot to its right position
SwapItems varArray, 1, i - 1
newlngRight = i - 1

End Sub


Sub Load_Integers(varArray() As Long, length As Long)
Dim k As Integer


ReDim varArray(length)
k = 0
For k = 1 To length
varArray(k) = Range("a" & k)
Next k


left = LBound(varArray)
right = UBound(varArray)


End Sub

Sub ComparisonsAndQuickSort(arr() As Long, lower As Long, upper As Long)

If lower < upper Then

PartitionQuickSort arr(), lower, upper

'ComparisonCounter = ComparisonCounter + (upper - 1)
ComparisonsAndQuickSort arr, lower, newlngRight
ComparisonsAndQuickSort arr, newlngRight + 1, upper

End If
End Sub


Sub SwapItems(arrSwap() As Long, Item1 As Long, Item2 As Long)
'Swap not sorted items
Dim temp As Integer


temp = arrSwap(Item2)
arrSwap(Item2) = arrSwap(Item1)
arrSwap(Item1) = temp


End Sub



Thank you in advance
George

[Paul_Hossler]

I'm not sure that your recursion-ing is correct

FWIW, this is the quick sort I got off the web a long time ago




Sub FillAndSort()
Dim A(1 To 100) As Long
Dim i As Long

For i = LBound(A) To UBound(A)
A(i) = Int(100 * Rnd())
Next i
Call QuickSort(A, LBound(A), UBound(A))
For i = LBound(A) To UBound(A)
Debug.Print A(i)
Next i
End Sub

Sub QuickSort(ByRef SortArray As Variant, ByVal First As Long, ByVal Last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant

Low = First
High = Last

List_Separator = SortArray((First + Last) \ 2)

Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop

Do While (SortArray(High) > List_Separator)
High = High - 1
Loop

If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If

Loop While (Low <= High)

If (First < High) Then Call QuickSort(SortArray, First, High)
If (Low < Last) Then Call QuickSort(SortArray, Low, Last)
End Sub

[gk039]

Hi Paul,

Thank you for your input. I've seen the code you propose in a book and I've used it. But i am trying to implement quick-sort using the first element of the array as the pivot, not the middle one. My recursions is indeed incorrect and i am trying to figure out the problem

Thank you once more

[Kenneth Hobs]

I don't know what you are trying to achieve with recursion.

Here is a link to Chip Pearson's Quick Sort In Place method. http://www.cpearson.com/excel/SortingArrays.aspx

Here are two other sort methods. The last is the fastest of any that I have seen.

Sub test_RndIntPick()
Dim a() As Variant, b() As Variant, t1 As Double, s As String

t1 = Timer
b() = RndIntPick(5, 10000, 955)
s = CStr(Timer - t1) & " seconds for RndIntPick."
MsgBox Join(b(), vbLf), vbInformation, s

t1 = Timer
a() = InsertSort(b())
s = CStr(Timer - t1) & " seconds for InsertSort."
MsgBox Join(a(), vbLf), vbInformation, s

t1 = Timer
a() = ArrayListSort(b())
s = CStr(Timer - t1) & " seconds for ArrayList ascending."
MsgBox Join(a(), vbLf), vbInformation, s

t1 = Timer
a() = ArrayListSort(b(), False)
s = CStr(Timer - t1) & " seconds for ArrayList descending."
MsgBox Join(a(), vbLf), vbInformation, s
End Sub


Function RndIntPick(first As Long, last As Long, _
noPick As Long, Optional bSort As Boolean = False) As Variant
Dim i As Long, r As Long, temp As Long, k As Long
ReDim iArr(first To last) As Variant
Dim a() As Variant

For i = first To last
iArr(i) = i
Next i

Randomize
For i = 1 To noPick
r = Int(Rnd() * (last - first + 1 - (i - 1))) + (first + (i - 1))
temp = iArr(r)
iArr(r) = iArr(first + i - 1)
iArr(first + i - 1) = temp
Next i

ReDim Preserve iArr(first To first + noPick - 1)
ReDim a(1 To noPick)
For r = 1 To noPick
a(r) = iArr(LBound(iArr) + r - 1)
Next r

If bSort = True Then
RndIntPick = ArrayListSort(a())
Else
RndIntPick = a()
End If
End Function


Function ArrayListSort(sn As Variant, Optional bAscending As Boolean = True)
With CreateObject("System.Collections.ArrayList")
Dim cl As Variant
For Each cl In sn
.Add cl
Next

.Sort 'Sort ascendending
If bAscending = False Then .Reverse 'Sort and then Reverse to sort descending
ArrayListSort = .toarray()
End With
End Function


'http://vbadeveloper.net/sortingvbabubbleinsertionquick.pdf
' Changed array to variant by Kenneth Hobson, 12/19/13.
Function InsertSort(Array_Values) As Variant 'Sorts ascending
Dim nums() As Double
Dim limit As Long
Dim i As Long, j As Long
Dim num_greater
Dim new_array() As Variant
Dim base_variable As Double
Dim Rank As Long

limit = UBound(Array_Values)

ReDim Preserve nums(1 To limit)
ReDim Preserve new_array(1 To limit)

For i = 1 To limit
nums(i) = Array_Values(i)
Next i

For i = 1 To limit
num_greater = 0
base_variable = nums(i)
For j = 1 To limit
If base_variable < nums(j) Then
num_greater = num_greater + 1
End If
Next j

Rank = limit - num_greater
new_array(Rank) = nums(i)
Next i

'InsertSort = WorksheetFunction.Transpose(new_array)
InsertSort = new_array
End Function

[Paul_Hossler]

@gk039


But i am trying to implement quick-sort using the first element of the array as the pivot, not the middle one

Not an expert by any means, but I think Quicksort works by a pivot index and using recursion to QuickSort each of the pieces above and below the pivot .....repeat


But in any event, this statement looks funny to me



For j = j To lngRight

[mikerickson]

About the pivot:
If the array is already sorted, using the first element as the pivot will result in as many loops as a bubble sort. (i.e. slow). If the array is almost sorted, using pivot choosing to select the middle element as the pivot will be much faster. But that calculation slows things down a tiny bit.

If the use is user enters a list > sort > user adds to list > sort again, the time savings from pivot choosing is worth it.
If the use is to sort a random list once, pivot choosing is a minor time hit, and not needed.

Below is my version of a Quick Sort (perhaps not strictly a quick sort). It does not use recursion, but sorts the array in place.
QuickSortArray is a sub that will sort an array. QuickSortedArray is a function that, given an unsorted array, will return a sorted array.
Note the optional Descending argument.


Dim Stack() As Long
Dim StackPointer As Long

Sub test()
Dim x As Long, y As Long
Dim unsArray As Variant, sArray As Variant

unsArray = Array(2, 3, 4, 1, 34, 18, -34)
sArray = QuickSortedArray(unsArray, True)

MsgBox "unsorted: " & Join(unsArray) & vbCr & " sorted : " & Join(sArray)
End Sub

Function QuickSortedArray(ByRef unsortedArray, Optional Descending As Boolean) As Variant
Dim Result As Variant
Result = unsortedArray
QuickSortArray Result, Descending
QuickSortedArray = Result
End Function

Sub QuickSortArray(ByRef SortArray As Variant, Optional Descending As Boolean)
Dim Pivot As Variant, PivotPlace As Long
Dim Low As Long, High As Long
Dim i As Long, temp As Variant

StackPointer = 0
Push LBound(SortArray), UBound(SortArray)

Do Until StackPointer <= 0
Pop Low, High

Rem optional code for pivot choosing
i = (Low + High) / 2
temp = SortArray(i)
SortArray(i) = SortArray(High)
SortArray(High) = temp
Rem end pivot choosing

Pivot = SortArray(High)
PivotPlace = Low

For i = Low To High - 1
If (SortArray(i) < Pivot) Xor Descending Then
temp = SortArray(i)
SortArray(i) = SortArray(PivotPlace)
SortArray(PivotPlace) = temp
PivotPlace = PivotPlace + 1
End If
Next i

SortArray(High) = SortArray(PivotPlace)
SortArray(PivotPlace) = Pivot

If Low < PivotPlace Then Push Low, PivotPlace - 1
If PivotPlace < High Then Push PivotPlace + 1, High
Loop
End Sub

Sub Push(a As Long, b As Long)
On Error GoTo MakeStack

StackPointer = StackPointer + 1
If UBound(Stack, 2) < StackPointer Then ReDim Preserve Stack(1 To 2, 1 To 2 * StackPointer)
Stack(1, StackPointer) = a
Stack(2, StackPointer) = b

Exit Sub
MakeStack:
ReDim Stack(1 To 2, 1 To 1)
Err.Clear
Resume
End Sub

Function Pop(ByRef a As Long, ByRef b As Long) As Boolean
If StackPointer <= 0 Then
Pop = False
Else
a = Stack(1, StackPointer)
b = Stack(2, StackPointer)
Pop = True
End If
StackPointer = StackPointer - 1
End Function

[snb]

This code also does the sorting job of an array:


Sub M_snb()
sheet1.Columns(3).SpecialCells(2).Name = "snb"
sn = [snb]
sp = [index(--(snb>transpose(snb)),)]

For j = 1 To UBound(sp)
sn(Application.Sum(Application.Index(sp, j)) + 1, 1) = [snb].Cells(j)
Next

Sheet1.Cells(1).Resize(UBound(sn)) = sn
End Sub

[Paul_Hossler]

If you know how well sorted the data is in advance and depending on if you want a stable sort (equal keys retain same relative position) you can choose the most appropriate algorithm.

Quicksort is not stable which may or may not be important


The site

http://www.sorting-algorithms.com/

Has an interesting animation for 4 types of data and 8 different sorts where you can click on a row to visually compare sorts, or on a sort to visually see how it works with differet types of data

14701



I thought it was interesting anyways :yes, even if it is a little off topic

[snb]

@KH

Which one of the methods you showed do you describe as the 'fastest' ?

[Kenneth Hobs]

QuickSort is faster by just a bit in my tests sorting random integers.

We had this discussion about array sorting speed some time back. Of course my file only looked at random integer sorting. One needs to look at numbers, characters, and a mix to see which method is the "fastest".

I think that the System Collection method is my preference. Here is a link to my file. I just looked at a few methods. Paul example looks interesting.

[snb]

Thanks.

Maybe you already were familiar with:


Sub unique_sortedlist_snb()
sn = Split("een_twee_drie_vier_vijf_een_twee_zes_twee_zeven", "_")

With CreateObject("System.Collections.SortedList")
For Each it In sn
.Item(it) = it
Next

For j = 0 To .Count - 1
c00 = c00 & vbLf & .getbyindex(j)
c01 = c01 & vbLf & .getkey(j)
Next
End With

MsgBox c01
MsgBox c00
End Sub

And


Sub M_snb_sorteer_1dimensionele_array()
sn = Split("een_twee_drie_vier_vijf_een_twee_zes_twee_zeven", "_")

With CreateObject("ADODB.recordset")
.Fields.Append "item_1", 200, 30
.Open
For j = 1 To UBound(sn)
.AddNew
.Fields("item_1") = sn(j)
.Update
Next
.Sort = "item_1"

MsgBox .GetString
End With
End Sub