[SOLVED] VBA array sort function?

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. @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 @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

excel_workbook.Activate

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

Case "yes"
Case "no"
Case "guess"
Case Else
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
Case 2
Case 3
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
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
``` 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 (). @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.

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

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