Here’s a multi-column and a single-column QuickSort for VBA, modified from a code sample posted by Jim Rech on Usenet.
Notes:
You’ll notice that I do a lot more defensive coding than you’ll see in most of the code samples out there on the web: this is an Excel forum, and you’ve got to anticipate nulls and empty values… Or nested arrays and objects in arrays if your source array comes from (say) a third-party realtime market data source.
Empty values and invalid items are sent to the end of the list.
To sort multi-column arrays, your call will be:
QuickSortArray MyArray,,,2
…Passing ‘2’ as the column to sort on and excluding the optional parameters that pass the upper and lower bounds of the search domain.
Sorting single-column arrays (vectors), instead use:
QuickSortVector Myarray
Here too excluding the optional parameters.
[EDITED] – fixed an odd formatting glitch in the <code> tags, which seem to have a problem with hyperlinks in code comments.
The Hyperlink I excised was Detecting an Array Variant in VBA.
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
' SampleUsage: 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
… And the single-column array version:
Public Sub QuickSortVector(ByRef SortArray As Variant, Optional lngMin As Long = -1, Optional lngMax As Long = -1)
On Error Resume Next
'Sort a 1-Dimensional array
' SampleUsage: sort arrData
'
' QuickSortVector arrData
'
' Originally posted by Jim Rech 10/20/98 Excel.Programming
' Modifications, Nigel Heffernan:
' ' Escape failed comparison with an empty variant in the array
' ' Defensive coding: check inputs
Dim i As Long
Dim j As Long
Dim varMid As Variant
Dim varX As Variant
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)
End If
If lngMax = -1 Then
lngMax = UBound(SortArray)
End If
If lngMin >= lngMax Then ' no sorting required
Exit Sub
End If
i = lngMin
j = lngMax
varMid = Empty
varMid = SortArray((lngMin + lngMax) \ 2)
' 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 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) < varMid And i < lngMax
i = i + 1
Wend
While varMid < SortArray(j) And j > lngMin
j = j - 1
Wend
If i <= j Then
' Swap the item
varX = SortArray(i)
SortArray(i) = SortArray(j)
SortArray(j) = varX
i = i + 1
j = j - 1
End If
Wend
If (lngMin < j) Then Call QuickSortVector(SortArray, lngMin, j)
If (i < lngMax) Then Call QuickSortVector(SortArray, i, lngMax)
End Sub
I used to use BubbleSort for this kind of thing, but it slows down, severely, after the array exceeds 1024 rows. I include the code below for your reference: please note that I haven’t provided source code for ArrayDimensions, so this will not compile for you unless you refactor it – or split it out into ‘Array’ and ‘vector’ versions.
Public Sub BubbleSort(ByRef InputArray, Optional SortColumn As Integer = 0, Optional Descending As Boolean = False) ' Sort a 1- or 2-Dimensional array. Dim iFirstRow As Integer Dim iLastRow As Integer Dim iFirstCol As Integer Dim iLastCol As Integer Dim i As Integer Dim j As Integer Dim k As Integer Dim varTemp As Variant Dim OutputArray As Variant Dim iDimensions As Integer iDimensions = ArrayDimensions(InputArray) Select Case iDimensions Case 1 iFirstRow = LBound(InputArray) iLastRow = UBound(InputArray) For i = iFirstRow To iLastRow - 1 For j = i + 1 To iLastRow If InputArray(i) > InputArray(j) Then varTemp = InputArray(j) InputArray(j) = InputArray(i) InputArray(i) = varTemp End If Next j Next i Case 2 iFirstRow = LBound(InputArray, 1) iLastRow = UBound(InputArray, 1) iFirstCol = LBound(InputArray, 2) iLastCol = UBound(InputArray, 2) If SortColumn InputArray(j, SortColumn) Then For k = iFirstCol To iLastCol varTemp = InputArray(j, k) InputArray(j, k) = InputArray(i, k) InputArray(i, k) = varTemp Next k End If Next j Next i End Select If Descending Then OutputArray = InputArray For i = LBound(InputArray, 1) To UBound(InputArray, 1) k = 1 + UBound(InputArray, 1) - i For j = LBound(InputArray, 2) To UBound(InputArray, 2) InputArray(i, j) = OutputArray(k, j) Next j Next i Erase OutputArray End If End Sub
This answer may have arrived a bit late to solve your problem when you needed to, but other people will pick it up when they Google for answers for similar problems.