By Mark Nold


2008-09-30 09:06:04 8 Comments

I'm looking for a decent sort implementation for arrays in VBA. A Quicksort would be preferred. Or any other sort algorithm other than bubble or merge would suffice.

Please note that this is to work with MS Project 2003, so should avoid any of the Excel native functions and anything .net related.

11 comments

@Jean-Claude Arbaut 2019-06-20 15:26:47

Heapsort implementation. An O(n log(n)) (both average and worst case), in place, unstable sorting algorithm.

Use with: Call HeapSort(A), where A is a one dimensional array of variants, with Option Base 1.

Sub SiftUp(A() As Variant, I As Long)
    Dim K As Long, P As Long, S As Variant
    K = I
    While K > 1
        P = K \ 2
        If A(K) > A(P) Then
            S = A(P): A(P) = A(K): A(K) = S
            K = P
        Else
            Exit Sub
        End If
    Wend
End Sub

Sub SiftDown(A() As Variant, I As Long)
    Dim K As Long, L As Long, S As Variant
    K = 1
    Do
        L = K + K
        If L > I Then Exit Sub
        If L + 1 <= I Then
            If A(L + 1) > A(L) Then L = L + 1
        End If
        If A(K) < A(L) Then
            S = A(K): A(K) = A(L): A(L) = S
            K = L
        Else
            Exit Sub
        End If
    Loop
End Sub

Sub HeapSort(A() As Variant)
    Dim N As Long, I As Long, S As Variant
    N = UBound(A)
    For I = 2 To N
        Call SiftUp(A, I)
    Next I
    For I = N To 2 Step -1
        S = A(I): A(I) = A(1): A(1) = S
        Call SiftDown(A, I - 1)
    Next
End Sub

@Jorge Ferreira 2008-09-30 09:10:21

Take a look here:
Edit: The referenced source (allexperts.com) has since closed, but here are the relevant author comments:

There are many algorithms available on the web for sorting. The most versatile and usually the quickest is the Quicksort algorithm. Below is a function for it.

Call it simply by passing an array of values (string or numeric; it doesn't matter) with the Lower Array Boundary (usually 0) and the Upper Array Boundary (i.e. UBound(myArray).)

Example: Call QuickSort(myArray, 0, UBound(myArray))

When it's done, myArray will be sorted and you can do what you want with it.
(Source: archive.org)

Public Sub QuickSort(vArray As Variant, inLow As Long, inHi As Long)
  Dim pivot   As Variant
  Dim tmpSwap As Variant
  Dim tmpLow  As Long
  Dim tmpHi   As Long

  tmpLow = inLow
  tmpHi = inHi

  pivot = vArray((inLow + inHi) \ 2)

  While (tmpLow <= tmpHi)
     While (vArray(tmpLow) < pivot And tmpLow < inHi)
        tmpLow = tmpLow + 1
     Wend

     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     Wend

     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  Wend

  If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi
  If (tmpLow < inHi) Then QuickSort vArray, tmpLow, inHi
End Sub

Note that this only works with single-dimensional (aka "normal"?) arrays. (There's a working multi-dimensional array QuickSort here.)

@Mark Nold 2008-10-01 02:50:57

This is the slightly faster implementation when dealing with duplicates. Probably due to the \ 2. Good answer :)

@djule5 2011-10-14 13:23:26

Thanks a lot for that! I was using an insertion sort on a 2500 entries data set and it would take about 22 seconds to sort properly. Now it does it under a second, it's a miracle! ;)

@Jasmine 2015-10-08 19:30:55

The effect of this function seems to be always moving the first item from the source, to the last position in the destination, and sorting the rest of the array just fine.

@Egalth 2018-01-18 20:20:25

Still a nice solution 9+ years later. But unfortunately the referenced page allexperts.com no longer exists...

@ashleedawg 2018-05-10 01:34:08

@Egalth - I've updated the question with the information that was on the original source

@Nad Alaba 2019-02-20 14:50:38

@Jasmine Can you give an example of an array that's not working fine with this function?

@ChrisB 2019-06-07 20:35:12

Are the seemingly redundant parenthesis necessary? Examples: While (tmpLow <= tmpHi), While (vArray(tmpLow) < pivot And tmpLow < inHi), If (tmpLow <= tmpHi) Then and If (inLow < tmpHi) Then QuickSort vArray, inLow, tmpHi

@Reged 2016-06-12 22:22:50

This is what I use to sort in memory - it can easily be expanded to sort an array.

Sub sortlist()

    Dim xarr As Variant
    Dim yarr As Variant
    Dim zarr As Variant

    xarr = Sheets("sheet").Range("sing col range")
    ReDim yarr(1 To UBound(xarr), 1 To 1)
    ReDim zarr(1 To UBound(xarr), 1 To 1)

    For n = 1 To UBound(xarr)
        zarr(n, 1) = 1
    Next n

    For n = 1 To UBound(xarr) - 1
        y = zarr(n, 1)
        For a = n + 1 To UBound(xarr)
            If xarr(n, 1) > xarr(a, 1) Then
                y = y + 1
            Else
                zarr(a, 1) = zarr(a, 1) + 1
            End If
        Next a
        yarr(y, 1) = xarr(n, 1)
    Next n

    y = zarr(UBound(xarr), 1)
    yarr(y, 1) = xarr(UBound(xarr), 1)

    yrng = "A1:A" & UBound(yarr)
    Sheets("sheet").Range(yrng) = yarr

End Sub

@lucas0x7B 2011-05-25 11:12:53

You didn't want an Excel-based solution but since I had the same problem today and wanted to test using other Office Applications functions I wrote the function below.

Limitations:

  • 2-dimensional arrays;
  • maximum of 3 columns as sort keys;
  • depends on Excel;

Tested calling Excel 2010 from Visio 2010


Option Base 1


Private Function sort_array_2D_excel(array_2D, array_sortkeys, Optional array_sortorders, Optional tag_header As String = "Guess", Optional tag_matchcase As String = "False")

'   Dependencies: Excel; Tools > References > Microsoft Excel [Version] Object Library

    Dim excel_application As Excel.Application
    Dim excel_workbook As Excel.Workbook
    Dim excel_worksheet As Excel.Worksheet

    Set excel_application = CreateObject("Excel.Application")

    excel_application.Visible = True
    excel_application.ScreenUpdating = False
    excel_application.WindowState = xlNormal

    Set excel_workbook = excel_application.Workbooks.Add
    excel_workbook.Activate

    Set excel_worksheet = excel_workbook.Worksheets.Add
    excel_worksheet.Activate
    excel_worksheet.Visible = xlSheetVisible

    Dim excel_range As Excel.Range
    Set excel_range = excel_worksheet.Range("A1").Resize(UBound(array_2D, 1) - LBound(array_2D, 1) + 1, UBound(array_2D, 2) - LBound(array_2D, 2) + 1)
    excel_range = array_2D


    For i_sortkey = LBound(array_sortkeys) To UBound(array_sortkeys)

        If IsNumeric(array_sortkeys(i_sortkey)) Then
            sortkey_range = Chr(array_sortkeys(i_sortkey) + 65 - 1) & "1"
            Set array_sortkeys(i_sortkey) = excel_worksheet.Range(sortkey_range)

        Else
            MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
            End

        End If

    Next i_sortkey


    For i_sortorder = LBound(array_sortorders) To UBound(array_sortorders)
        Select Case LCase(array_sortorders(i_sortorder))
            Case "asc"
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
            Case "desc"
                array_sortorders(i_sortorder) = XlSortOrder.xlDescending
            Case Else
                array_sortorders(i_sortorder) = XlSortOrder.xlAscending
        End Select
    Next i_sortorder

    Select Case LCase(tag_header)
        Case "yes"
            tag_header = Excel.xlYes
        Case "no"
            tag_header = Excel.xlNo
        Case "guess"
            tag_header = Excel.xlGuess
        Case Else
            tag_header = Excel.xlGuess
    End Select

    Select Case LCase(tag_matchcase)
        Case "true"
            tag_matchcase = True
        Case "false"
            tag_matchcase = False
        Case Else
            tag_matchcase = False
    End Select


    Select Case (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
        Case 1
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 2
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Header:=tag_header, MatchCase:=tag_matchcase)
        Case 3
            Call excel_range.Sort(Key1:=array_sortkeys(1), Order1:=array_sortorders(1), Key2:=array_sortkeys(2), Order2:=array_sortorders(2), Key3:=array_sortkeys(3), Order3:=array_sortorders(3), Header:=tag_header, MatchCase:=tag_matchcase)
        Case Else
            MsgBox "Error in sortkey parameter:" & vbLf & "Maximum number of sort columns is 3!" & vbLf & "Currently passed: " & (UBound(array_sortkeys) - LBound(array_sortkeys) + 1)
            End
    End Select


    For i_row = 1 To excel_range.Rows.Count

        For i_column = 1 To excel_range.Columns.Count

            array_2D(i_row, i_column) = excel_range(i_row, i_column)

        Next i_column

    Next i_row


    excel_workbook.Close False
    excel_application.Quit

    Set excel_worksheet = Nothing
    Set excel_workbook = Nothing
    Set excel_application = Nothing


    sort_array_2D_excel = array_2D


End Function

This is an example on how to test the function:

Private Sub test_sort()

    array_unsorted = dim_sort_array()

    Call msgbox_array(array_unsorted)

    array_sorted = sort_array_2D_excel(array_unsorted, Array(2, 1, 3), Array("desc", "", "asdas"), "yes", "False")

    Call msgbox_array(array_sorted)

End Sub


Private Function dim_sort_array()

    Dim array_unsorted(1 To 5, 1 To 3) As String

    i_row = 0

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "Column1": array_unsorted(i_row, 2) = "Column2": array_unsorted(i_row, 3) = "Column3"

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "OR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "XOR": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "NOT": array_unsorted(i_row, 2) = "B": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    i_row = i_row + 1
    array_unsorted(i_row, 1) = "AND": array_unsorted(i_row, 2) = "A": array_unsorted(i_row, 3) = array_unsorted(i_row, 1) & "_" & array_unsorted(i_row, 2)

    dim_sort_array = array_unsorted

End Function


Sub msgbox_array(array_2D, Optional string_info As String = "2D array content:")

    msgbox_string = string_info & vbLf

    For i_row = LBound(array_2D, 1) To UBound(array_2D, 1)

        msgbox_string = msgbox_string & vbLf & i_row & vbTab

        For i_column = LBound(array_2D, 2) To UBound(array_2D, 2)

            msgbox_string = msgbox_string & array_2D(i_row, i_column) & vbTab

        Next i_column

    Next i_row

    MsgBox msgbox_string

End Sub

If anybody tests this using other versions of office please post here if there are any problems.

@lucas0x7B 2011-05-25 11:19:09

I forgot to mention that msgbox_array() is a function that's useful to inspect any 2-dimensional array quickly while debugging.

@Profex 2013-10-16 22:47:29

Natural Number (Strings) Quick Sort

Just to pile onto the topic. Normally, if you sort strings with numbers you'll get something like this:

    Text1
    Text10
    Text100
    Text11
    Text2
    Text20

But you really want it to recognize the numerical values and be sorted like

    Text1
    Text2
    Text10
    Text11
    Text20
    Text100

Here's how to do it...

Note:

  • I stole the Quick Sort from the internet a long time ago, not sure where now...
  • I translated the CompareNaturalNum function which was originally written in C from the internet as well.
  • Difference from other Q-Sorts: I don't swap the values if the BottomTemp = TopTemp

Natural Number Quick Sort

Public Sub QuickSortNaturalNum(strArray() As String, intBottom As Integer, intTop As Integer)
Dim strPivot As String, strTemp As String
Dim intBottomTemp As Integer, intTopTemp As Integer

    intBottomTemp = intBottom
    intTopTemp = intTop

    strPivot = strArray((intBottom + intTop) \ 2)

    Do While (intBottomTemp <= intTopTemp)
        ' < comparison of the values is a descending sort
        Do While (CompareNaturalNum(strArray(intBottomTemp), strPivot) < 0 And intBottomTemp < intTop)
            intBottomTemp = intBottomTemp + 1
        Loop
        Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
            intTopTemp = intTopTemp - 1
        Loop
        If intBottomTemp < intTopTemp Then
            strTemp = strArray(intBottomTemp)
            strArray(intBottomTemp) = strArray(intTopTemp)
            strArray(intTopTemp) = strTemp
        End If
        If intBottomTemp <= intTopTemp Then
            intBottomTemp = intBottomTemp + 1
            intTopTemp = intTopTemp - 1
        End If
    Loop

    'the function calls itself until everything is in good order
    If (intBottom < intTopTemp) Then QuickSortNaturalNum strArray, intBottom, intTopTemp
    If (intBottomTemp < intTop) Then QuickSortNaturalNum strArray, intBottomTemp, intTop
End Sub

Natural Number Compare(Used in Quick Sort)

Function CompareNaturalNum(string1 As Variant, string2 As Variant) As Integer
'string1 is less than string2 -1
'string1 is equal to string2 0
'string1 is greater than string2 1
Dim n1 As Long, n2 As Long
Dim iPosOrig1 As Integer, iPosOrig2 As Integer
Dim iPos1 As Integer, iPos2 As Integer
Dim nOffset1 As Integer, nOffset2 As Integer

    If Not (IsNull(string1) Or IsNull(string2)) Then
        iPos1 = 1
        iPos2 = 1
        Do While iPos1 <= Len(string1)
            If iPos2 > Len(string2) Then
                CompareNaturalNum = 1
                Exit Function
            End If
            If isDigit(string1, iPos1) Then
                If Not isDigit(string2, iPos2) Then
                    CompareNaturalNum = -1
                    Exit Function
                End If
                iPosOrig1 = iPos1
                iPosOrig2 = iPos2
                Do While isDigit(string1, iPos1)
                    iPos1 = iPos1 + 1
                Loop

                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                Loop

                nOffset1 = (iPos1 - iPosOrig1)
                nOffset2 = (iPos2 - iPosOrig2)

                n1 = Val(Mid(string1, iPosOrig1, nOffset1))
                n2 = Val(Mid(string2, iPosOrig2, nOffset2))

                If (n1 < n2) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (n1 > n2) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                ' front padded zeros (put 01 before 1)
                If (n1 = n2) Then
                    If (nOffset1 > nOffset2) Then
                        CompareNaturalNum = -1
                        Exit Function
                    ElseIf (nOffset1 < nOffset2) Then
                        CompareNaturalNum = 1
                        Exit Function
                    End If
                End If
            ElseIf isDigit(string2, iPos2) Then
                CompareNaturalNum = 1
                Exit Function
            Else
                If (Mid(string1, iPos1, 1) < Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = -1
                    Exit Function
                ElseIf (Mid(string1, iPos1, 1) > Mid(string2, iPos2, 1)) Then
                    CompareNaturalNum = 1
                    Exit Function
                End If

                iPos1 = iPos1 + 1
                iPos2 = iPos2 + 1
            End If
        Loop
        ' Everything was the same so far, check if Len(string2) > Len(String1)
        ' If so, then string1 < string2
        If Len(string2) > Len(string1) Then
            CompareNaturalNum = -1
            Exit Function
        End If
    Else
        If IsNull(string1) And Not IsNull(string2) Then
            CompareNaturalNum = -1
            Exit Function
        ElseIf IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 0
            Exit Function
        ElseIf Not IsNull(string1) And IsNull(string2) Then
            CompareNaturalNum = 1
            Exit Function
        End If
    End If
End Function

isDigit(Used in CompareNaturalNum)

Function isDigit(ByVal str As String, pos As Integer) As Boolean
Dim iCode As Integer
    If pos <= Len(str) Then
        iCode = Asc(Mid(str, pos, 1))
        If iCode >= 48 And iCode <= 57 Then isDigit = True
    End If
End Function

@Mark Nold 2016-05-24 13:26:49

Nice - i like the NaturalNumber sort - will have to add this as an option

@Prasand Kumar 2017-07-28 17:42:23

Dim arr As Object
Dim InputArray

'Creating a array list
Set arr = CreateObject("System.Collections.ArrayList")

'String
InputArray = Array("d", "c", "b", "a", "f", "e", "g")

'number
'InputArray = Array(6, 5, 3, 4, 2, 1)

' adding the elements in the array to array_list
For Each element In InputArray
    arr.Add element
Next

'sorting happens
arr.Sort

'Converting ArrayList to an array
'so now a sorted array of elements is stored in the array sorted_array.

sorted_array = arr.toarray

@not2qubit 2017-10-29 10:21:17

Can you convert this to a function and show example output? Any ideas about the speed?

@Patrick Artner 2018-01-18 09:52:23

@Ans rejected your edit - you removed all the comments on your conversion so only uncommented code was left (as function). Shortness is nice but not when reducing "understandability" for other readers of this anwer.

@Ans 2018-01-18 10:19:23

@Patrick Artner The code is very simple, especially compared to other examples posted here. I'd think that if someone was looking for the simplest example here he would be able to find this one faster if only the relevant code was left.

@ZygD 2018-08-14 13:42:36

Would be a great answer, but you will probably have to deal with an issue that System.Collections.ArrayList is located in different locations in 32bit and 64bit Windows. My 32bit Excel implicitly tries to find it in location where 32bit Win would store it, but since I have 64bit Win, I also have a problem :/ I get an error -2146232576 (80131700).

@Moreno 2017-01-27 04:26:20

I think my code (tested) is more "educated", assuming the simpler the better.

Option Base 1

'Function to sort an array decscending
Function SORT(Rango As Range) As Variant
    Dim check As Boolean
    check = True
    If IsNull(Rango) Then
        check = False
    End If
    If check Then
        Application.Volatile
        Dim x() As Variant, n As Double, m As Double, i As Double, j As Double, k As Double
        n = Rango.Rows.Count: m = Rango.Columns.Count: k = n * m
        ReDim x(n, m)
        For i = 1 To n Step 1
            For j = 1 To m Step 1
                x(i, j) = Application.Large(Rango, k)
                k = k - 1
            Next j
        Next i
        SORT = x
    Else
        Exit Function
    End If
End Function

@not2qubit 2017-10-29 09:54:35

What kind of sort is this? And why do you say it's "educated"?

@ZygD 2018-08-14 14:02:59

From reading the code, it seems that it "sorts" the whole 2-dimensional array (taken from Excel sheet) on the whole array (not on some particular dimension). So values will change their dimensional indexes. And then the result is put back to the sheet.

@Profex 2018-10-23 17:05:26

While the code may work for simple cases, there are a lot of issues with this code. The first thing that I notice is the use of Double instead of Long everywhere. Second, it doesn't take into account if the range has multiple areas. Sorting a rectangle doesn't seem useful and of course it's not what the OP asked for (specifically said no native Excel/.Net solutions). Also, if you equate the simpler the better is more "educated", then wouldn't using the built in Range.Sort() function be best?

@Nigel Heffernan 2011-02-24 12:23:30

I posted some code in answer to a related question on StackOverflow:

Sorting a multidimensionnal array in VBA

The code samples in that thread include:

  1. A vector array Quicksort;
  2. A multi-column array QuickSort;
  3. A BubbleSort.

Alain's optimised Quicksort is very shiny: I just did a basic split-and-recurse, but the code sample above has a 'gating' function that cuts down on redundant comparisons of duplicated values. On the other hand, I code for Excel, and there's a bit more in the way of defensive coding - be warned, you'll need it if your array contains the pernicious 'Empty()' variant, which will break your While... Wend comparison operators and trap your code in an infinite loop.

Note that quicksort algorthms - and any recursive algorithm - can fill the stack and crash Excel. If your array has fewer than 1024 members, I'd use a rudimentary BubbleSort.

Public Sub QuickSortArray(ByRef SortArray As Variant, _
                                Optional lngMin As Long = -1, _ 
                                Optional lngMax As Long = -1, _ 
                                Optional lngColumn As Long = 0)
On Error Resume Next
'Sort a 2-Dimensional array
' Sample Usage: sort arrData by the contents of column 3 ' ' QuickSortArray arrData, , , 3
' 'Posted by Jim Rech 10/20/98 Excel.Programming
'Modifications, Nigel Heffernan:
' ' Escape failed comparison with empty variant ' ' Defensive coding: check inputs
Dim i As Long Dim j As Long Dim varMid As Variant Dim arrRowTemp As Variant Dim lngColTemp As Long

If IsEmpty(SortArray) Then Exit Sub End If
If InStr(TypeName(SortArray), "()") < 1 Then 'IsArray() is somewhat broken: Look for brackets in the type name Exit Sub End If
If lngMin = -1 Then lngMin = LBound(SortArray, 1) End If
If lngMax = -1 Then lngMax = UBound(SortArray, 1) End If
If lngMin >= lngMax Then ' no sorting required Exit Sub End If

i = lngMin j = lngMax
varMid = Empty varMid = SortArray((lngMin + lngMax) \ 2, lngColumn)
' We send 'Empty' and invalid data items to the end of the list: If IsObject(varMid) Then ' note that we don't check isObject(SortArray(n)) - varMid might pick up a valid default member or property i = lngMax j = lngMin ElseIf IsEmpty(varMid) Then i = lngMax j = lngMin ElseIf IsNull(varMid) Then i = lngMax j = lngMin ElseIf varMid = "" Then i = lngMax j = lngMin ElseIf varType(varMid) = vbError Then i = lngMax j = lngMin ElseIf varType(varMid) > 17 Then i = lngMax j = lngMin End If

While i <= j
While SortArray(i, lngColumn) < varMid And i < lngMax i = i + 1 Wend
While varMid < SortArray(j, lngColumn) And j > lngMin j = j - 1 Wend

If i <= j Then
' Swap the rows ReDim arrRowTemp(LBound(SortArray, 2) To UBound(SortArray, 2)) For lngColTemp = LBound(SortArray, 2) To UBound(SortArray, 2) arrRowTemp(lngColTemp) = SortArray(i, lngColTemp) SortArray(i, lngColTemp) = SortArray(j, lngColTemp) SortArray(j, lngColTemp) = arrRowTemp(lngColTemp) Next lngColTemp Erase arrRowTemp
i = i + 1 j = j - 1
End If

Wend
If (lngMin < j) Then Call QuickSortArray(SortArray, lngMin, j, lngColumn) If (i < lngMax) Then Call QuickSortArray(SortArray, i, lngMax, lngColumn)

End Sub

@Konrad Rudolph 2008-09-30 09:12:24

Explanation in German but the code is a well-tested in-place implementation:

Private Sub QuickSort(ByRef Field() As String, ByVal LB As Long, ByVal UB As Long)
    Dim P1 As Long, P2 As Long, Ref As String, TEMP As String

    P1 = LB
    P2 = UB
    Ref = Field((P1 + P2) / 2)

    Do
        Do While (Field(P1) < Ref)
            P1 = P1 + 1
        Loop

        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        Loop

        If P1 <= P2 Then
            TEMP = Field(P1)
            Field(P1) = Field(P2)
            Field(P2) = TEMP

            P1 = P1 + 1
            P2 = P2 - 1
        End If
    Loop Until (P1 > P2)

    If LB < P2 Then Call QuickSort(Field, LB, P2)
    If P1 < UB Then Call QuickSort(Field, P1, UB)
End Sub

Invoked like this:

Call QuickSort(MyArray, LBound(MyArray), UBound(MyArray))

@Mark Nold 2008-10-01 02:47:33

I get an error for ByVal Field(), and have to use the default ByRef.

@Richard H 2015-09-01 09:30:00

@MarkNold - yup me too

@Patrick Lepelletier 2016-01-21 12:34:04

it's byref anyway, because byval wouldn't allow changing+saving Field values. If you absolutely need a byval in a passed argument, use a variant instead of string and no brakets ().

@Konrad Rudolph 2016-01-21 12:43:49

@Patrick Yeah, I haven’t really got a clue how the ByVal got in there. The confusion probably came from the fact that in VB.NET ByVal would work here (though this would be implemented differently in VB.NET anyway).

@Jarek 2015-11-17 11:22:25

I wonder what would you say about this array sorting code. It's quick for implementation and does the job ... haven't tested for large arrays yet. It works for one-dimensional arrays, for multidimensional additional values re-location matrix would need to be build (with one less dimension that the initial array).

       For AR1 = LBound(eArray, 1) To UBound(eArray, 1)
            eValue = eArray(AR1)
            For AR2 = LBound(eArray, 1) To UBound(eArray, 1)
                If eArray(AR2) < eValue Then
                    eArray(AR1) = eArray(AR2)
                    eArray(AR2) = eValue
                    eValue = eArray(AR1)
                End If
            Next AR2
        Next AR1

@Michiel van der Blonk 2015-11-23 01:34:20

This is bubble sort. The OP asked for something other than bubble.

@Alain 2010-12-03 16:37:58

I converted the 'fast quick sort' algorithm to VBA, if anyone else wants it.

I have it optimized to run on an array of Int/Longs but it should be simple to convert it to one that works on arbitrary comparable elements.

Private Sub QuickSort(ByRef a() As Long, ByVal l As Long, ByVal r As Long)
    Dim M As Long, i As Long, j As Long, v As Long
    M = 4

    If ((r - l) > M) Then
        i = (r + l) / 2
        If (a(l) > a(i)) Then swap a, l, i '// Tri-Median Methode!'
        If (a(l) > a(r)) Then swap a, l, r
        If (a(i) > a(r)) Then swap a, i, r

        j = r - 1
        swap a, i, j
        i = l
        v = a(j)
        Do
            Do: i = i + 1: Loop While (a(i) < v)
            Do: j = j - 1: Loop While (a(j) > v)
            If (j < i) Then Exit Do
            swap a, i, j
        Loop
        swap a, i, r - 1
        QuickSort a, l, j
        QuickSort a, i + 1, r
    End If
End Sub

Private Sub swap(ByRef a() As Long, ByVal i As Long, ByVal j As Long)
    Dim T As Long
    T = a(i)
    a(i) = a(j)
    a(j) = T
End Sub

Private Sub InsertionSort(ByRef a(), ByVal lo0 As Long, ByVal hi0 As Long)
    Dim i As Long, j As Long, v As Long

    For i = lo0 + 1 To hi0
        v = a(i)
        j = i
        Do While j > lo0
            If Not a(j - 1) > v Then Exit Do
            a(j) = a(j - 1)
            j = j - 1
        Loop
        a(j) = v
    Next i
End Sub

Public Sub sort(ByRef a() As Long)
    QuickSort a, LBound(a), UBound(a)
    InsertionSort a, LBound(a), UBound(a)
End Sub

@Alain 2010-12-03 16:40:12

These were the comments for the algorithm by the way: author James Gosling & Kevin A. Smith extended with TriMedian and InsertionSort by Denis Ahrens, with all the tips from Robert Sedgewick, It uses TriMedian and InsertionSort for lists shorter than 4. This is a generic version of C.A.R Hoare's Quick Sort algorithm. This will handle arrays that are already sorted, and arrays with duplicate keys.

@Alain 2010-12-03 19:59:31

Thank god I posted this. 3 hours later I crashed and lost my day's work, but am at least able to recover this. Now that's Karma at work. Computers are hard.

Related Questions

Sponsored Content

79 Answered Questions

[SOLVED] How do I remove a particular element from an array in JavaScript?

  • 2011-04-23 22:17:18
  • Walker
  • 5784432 View
  • 7214 Score
  • 79 Answer
  • Tags:   javascript arrays

30 Answered Questions

[SOLVED] How to append something to an array?

46 Answered Questions

27 Answered Questions

[SOLVED] Sorting an array of JavaScript objects by property

39 Answered Questions

[SOLVED] Loop through an array in JavaScript

32 Answered Questions

[SOLVED] Create ArrayList from array

41 Answered Questions

[SOLVED] Sort array of objects by string property value

34 Answered Questions

[SOLVED] How do I sort a dictionary by value?

33 Answered Questions

[SOLVED] For-each over an array in JavaScript?

9 Answered Questions

[SOLVED] Swift Beta performance: sorting arrays

Sponsored Content