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

Capture.JPG



I thought it was interesting anyways , 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