View Full Version : Quicksort code
gk039
11-02-2015, 03:51 PM
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
11-02-2015, 05:15 PM
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
11-03-2015, 02:52 PM
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
11-03-2015, 05:50 PM
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
11-03-2015, 06:48 PM
@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
11-03-2015, 07:38 PM
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
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
11-04-2015, 06:13 PM
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
@KH
Which one of the methods you showed do you describe as the 'fastest' ?
Kenneth Hobs
11-05-2015, 09:38 AM
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.
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
Powered by vBulletin® Version 4.2.5 Copyright © 2024 vBulletin Solutions Inc. All rights reserved.