Collectives™ on Stack Overflow

Find centralized, trusted content and collaborate around the technologies you use most.

Teams

Q&A for work

Connect and share knowledge within a single location that is structured and easy to search.

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.

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
     While (pivot < vArray(tmpHi) And tmpHi > inLow)
        tmpHi = tmpHi - 1
     If (tmpLow <= tmpHi) Then
        tmpSwap = vArray(tmpLow)
        vArray(tmpLow) = vArray(tmpHi)
        vArray(tmpHi) = tmpSwap
        tmpLow = tmpLow + 1
        tmpHi = tmpHi - 1
     End If
  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.)  
                This is the slightly faster implementation when dealing with duplicates. Probably due to the \ 2. Good answer :)
– Mark Nold
                Oct 1, 2008 at 2:50
                @ElieG. - I know this comment is old, but for anyone else with the same question, vba has two operators for dividing integers. / divides and rounds the result to the nearest integer. \ does an integer divide and truncates the decimal portion of the result
– Jason Wisnieski
                Mar 26, 2021 at 16:38
                To use it properly for case-sensitive string comparisons, I use Option Compare Text at the beginning of the module, otherwise it uses binary comparison.
– Dounchan
                Feb 24 at 23:44
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: 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
        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
        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
                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
                Dec 3, 2010 at 16:40
                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.
– Alain
                Dec 3, 2010 at 19:59
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 While (Field(P1) < Ref)
            P1 = P1 + 1
        Do While (Field(P2) > Ref)
            P2 = P2 - 1
        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))
                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 ().
– Patrick Lepelletier
                Jan 21, 2016 at 12:34
                @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).
– Konrad Rudolph
                Jan 21, 2016 at 12:43
' adding the elements in the array to array_list
For Each element In InputArray
    arr.Add element
'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
                @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.
– Patrick Artner
                Jan 18, 2018 at 9:52
                @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.
– Ans
                Jan 18, 2018 at 10:19
                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).
– ZygD
                Aug 14, 2018 at 13:42
                @ZygD The reason is most probably a missing installation of .NET Framework v3.5. Have added a note to the post (waiting for review of edit).
– mh166
                Nov 11, 2019 at 14:59
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
        Do While (CompareNaturalNum(strPivot, strArray(intTopTemp)) < 0 And intTopTemp > intBottom) '
            intTopTemp = intTopTemp - 1
        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
    '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
                Do While isDigit(string2, iPos2)
                    iPos2 = iPos2 + 1
                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
                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
        ' 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
        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
                my array ("test2", "test1", "test10", "test3") will be sorted to "test1", "test2", "test10", "test3", why is that? apperently 9 users voted this answer as a working solution, for me the order does not makes sense. Can someone please advice?
– smartini
                Jul 25, 2022 at 11:15
                @smartini, I only get that result if the bounds are not set correctly.  Specifically the top is missing the last element ([array,0,2] instead of [array,0,3]).
– Profex
                Oct 12, 2022 at 21:47
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:
A vector array Quicksort;
A multi-column array QuickSort;
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
     While varMid < SortArray(j, lngColumn) And j > lngMin
         j = j - 1
     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


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

 
End Sub

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
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)
            MsgBox "Error in sortkey parameter:" & vbLf & "array_sortkeys(" & i_sortkey & ") = " & array_sortkeys(i_sortkey) & vbLf & "Terminating..."
        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 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
    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
                I forgot to mention that msgbox_array() is a function that's useful to inspect any 2-dimensional array quickly while debugging.
– lucas0x7B
                May 25, 2011 at 11:19
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
            Exit Sub
        End If
End Sub
Sub SiftDown(A() As Variant, I As Long)
    Dim K As Long, L As Long, S As Variant
    K = 1
        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
            Exit Sub
        End If
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)
End Sub
@Prasand Kumar, here's a complete sort routine based on Prasand's concepts:
Public Sub ArrayListSort(ByRef SortArray As Variant)
    'Uses the sort capabilities of a System.Collections.ArrayList object to sort an array of values of any simple
    'data-type.
    'AUTHOR: Peter Straton
    'CREDIT: Derived from Prasand Kumar's post at: https://stackoverflow.com/questions/152319/vba-array-sort-function
    '*************************************************************************************************************
    Static ArrayListObj As Object
    Dim i As Long
    Dim LBnd As Long
    Dim UBnd As Long
    LBnd = LBound(SortArray)
    UBnd = UBound(SortArray)
    'If necessary, create the ArrayList object, to be used to sort the specified array's values
    If ArrayListObj Is Nothing Then
        Set ArrayListObj = CreateObject("System.Collections.ArrayList")
        ArrayListObj.Clear  'Already allocated so just clear any old contents
    End If
    'Add the ArrayList elements from the array of values to be sorted. (There appears to be no way to do this
    'using a single assignment statement.)
    For i = LBnd To UBnd
        ArrayListObj.Add SortArray(i)
    Next i
    ArrayListObj.Sort   'Do the sort
    'Transfer the sorted ArrayList values back to the original array, which can be done with a single assignment
    'statement.  But the result is always zero-based so then, if necessary, adjust the resulting array to match
    'its original index base.
    SortArray = ArrayListObj.ToArray
    If LBnd <> 0 Then ReDim Preserve SortArray(LBnd To UBnd)
End Sub
Somewhat related, but I was also looking for a native excel VBA solution since advanced data structures (Dictionaries, etc.) aren't working in my environment. The following implements sorting via a binary tree in VBA:
Assumes array is populated one by one
Removes duplicates
Returns a separated string ("0|2|3|4|9") which can then be split.
I used it for returning a raw sorted enumeration of rows selected for an arbitrarily selected range
Private Enum LeafType: tEMPTY: tTree: tValue: End Enum
Private Left As Variant, Right As Variant, Center As Variant
Private LeftType As LeafType, RightType As LeafType, CenterType As LeafType
Public Sub Add(x As Variant)
    If CenterType = tEMPTY Then
        Center = x
        CenterType = tValue
    ElseIf x > Center Then
        If RightType = tEMPTY Then
            Right = x
            RightType = tValue
        ElseIf RightType = tTree Then
            Right.Add x
        ElseIf x <> Right Then
            curLeaf = Right
            Set Right = New TreeList
            Right.Add curLeaf
            Right.Add x
            RightType = tTree
        End If
    ElseIf x < Center Then
        If LeftType = tEMPTY Then
            Left = x
            LeftType = tValue
        ElseIf LeftType = tTree Then
            Left.Add x
        ElseIf x <> Left Then
            curLeaf = Left
            Set Left = New TreeList
            Left.Add curLeaf
            Left.Add x
            LeftType = tTree
        End If
    End If
End Sub
Public Function GetList$()
    Const sep$ = "|"
    If LeftType = tValue Then
        LeftList$ = Left & sep
    ElseIf LeftType = tTree Then
        LeftList = Left.GetList & sep
    End If
    If RightType = tValue Then
        RightList$ = sep & Right
    ElseIf RightType = tTree Then
        RightList = sep & Right.GetList
    End If
    GetList = LeftList & Center & RightList
End Function
'Sample code
Dim Tree As new TreeList
Tree.Add("0")
Tree.Add("2")
Tree.Add("2")
Tree.Add("-1")
Debug.Print Tree.GetList() 'prints "-1|0|2"
sortedList = Split(Tree.GetList(),"|")
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
        Exit Function
    End If
End Function
                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.
– ZygD
                Aug 14, 2018 at 14:02
                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?
– Profex
                Oct 23, 2018 at 17:05
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
                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