I have defined the following Array Dim myArray(10,5) as Long and would like to sort it. What would be the best method to do that?
I will need to handle a lot of data like a 1000 x 5 Matrix. It contains mainly numbers and dates and need to sort it according to a certain column
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 MyarrayHere 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.
The hard part is that VBA provides no straightforward way to swap rows in a 2D array. For each swap, you're going to have to loop over 5 elements and swap each one, which will be very inefficient.
I'm guessing that a 2D array is really not what you should be using anyway though. Does each column have a specific meaning? If so, should you not be using an array of a user-defined type, or an array of objects that are instances of a class module? Even if the 5 columns don't have specific meanings, you could still do this, but define the UDT or class module to have just a single member that is a 5-element array.
For the sort algorithm itself, I would use a plain ol' Insertion Sort. 1000 items is actually not that big, and you probably won't notice the difference between an Insertion Sort and Quick Sort, so long as we've made sure that each swap will not be too slow. If you do use a Quick Sort, you'll need to code it carefully to make sure you won't run out of stack space, which can be done, but it's complicated, and Quick Sort is tricky enough already.
So assuming you use an array of UDTs, and assuming the UDT contains variants named Field1 through Field5, and assuming we want to sort on Field2 (for example), then the code might look something like this...
Type MyType
Field1 As Variant
Field2 As Variant
Field3 As Variant
Field4 As Variant
Field5 As Variant
End Type
Sub SortMyDataByField2(ByRef Data() As MyType)
Dim FirstIdx as Long, LastIdx as Long
FirstIdx = LBound(Data)
LastIdx = UBound(Data)
Dim I as Long, J as Long, Temp As MyType
For I=FirstIdx to LastIdx-1
For J=I+1 to LastIdx
If Data(I).Field2 > Data(J).Field2 Then
Temp = Data(I)
Data(I) = Data(J)
Data(J) = Temp
End If
Next J
Next I
End Sub
This is a tough one since it depends on many parameters, but after analyzing many algorithms I go with this one that overall has a stellar performance. On my machine which is not really fast, I sorted a 3 column array with 100k rows in 1 second. I tried fewer rows and it was a split second, however for one million rows I got between 9 and 26 seconds with different data (percentage of unsorted data has an impact anyway).
One routine for Ascending and one for Descending sorting. iCol, which is the 2nd argument is the index of the column on which the array is supposed to be sorted.
Public Sub MedianThreeQuickSort1_2D_Asc(ByRef pvarArray As Variant, _
ByVal iCol As Integer, _
Optional ByVal plngLeft As Long, _
Optional ByVal plngRight As Long)
'Grade A+
'NOTE: recursive routine, omit plngLeft & plngRight; they are used internally during recursion
Dim j As Integer
Dim lngFirst As Long
Dim lngLast As Long
Dim varMid As Variant
Dim lngIndex As Long
Dim varSwap As Variant
Dim a As Long
Dim b As Long
Dim c As Long
If plngRight = 0 Then
plngLeft = LBound(pvarArray, 1)
plngRight = UBound(pvarArray, 1)
End If
lngFirst = plngLeft
lngLast = plngRight
lngIndex = plngRight - plngLeft + 1
a = Int(lngIndex * Rnd) + plngLeft
b = Int(lngIndex * Rnd) + plngLeft
c = Int(lngIndex * Rnd) + plngLeft
If pvarArray(a, iCol) <= pvarArray(b, iCol) And pvarArray(b, iCol) <= pvarArray(c, iCol) Then
lngIndex = b
Else
If pvarArray(b, iCol) <= pvarArray(a, iCol) And pvarArray(a, iCol) <= pvarArray(c, iCol) Then
lngIndex = a
Else
lngIndex = c
End If
End If
varMid = pvarArray(lngIndex, iCol)
Do
Do While pvarArray(lngFirst, iCol) < varMid And lngFirst < plngRight
lngFirst = lngFirst + 1
Loop
Do While varMid < pvarArray(lngLast, iCol) And lngLast > plngLeft
lngLast = lngLast - 1
Loop
If lngFirst <= lngLast Then
For j = LBound(pvarArray, 2) To UBound(pvarArray, 2)
varSwap = pvarArray(lngLast, j)
pvarArray(lngLast, j) = pvarArray(lngFirst, j)
pvarArray(lngFirst, j) = varSwap
Next j
lngFirst = lngFirst + 1
lngLast = lngLast - 1
End If
Loop Until lngFirst > lngLast
If (lngLast - plngLeft) < (plngRight - lngFirst) Then
If plngLeft < lngLast Then MedianThreeQuickSort1_2D_Asc pvarArray, iCol, plngLeft, lngLast
If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Asc pvarArray, iCol, lngFirst, plngRight
Else
If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Asc pvarArray, iCol, lngFirst, plngRight
If plngLeft < lngLast Then MedianThreeQuickSort1_2D_Asc pvarArray, iCol, plngLeft, lngLast
End If
End Sub
Public Sub MedianThreeQuickSort1_2D_Desc(ByRef pvarArray As Variant, _
ByVal iCol As Integer, _
Optional ByVal plngLeft As Long, _
Optional ByVal plngRight As Long)
'Grade A+
'NOTE: recursive routine, omit plngLeft & plngRight; they are used internally during recursion
Dim j As Integer
Dim lngFirst As Long
Dim lngLast As Long
Dim varMid As Variant
Dim lngIndex As Long
Dim varSwap As Variant
Dim a As Long
Dim b As Long
Dim c As Long
If plngRight = 0 Then
plngLeft = LBound(pvarArray, 1)
plngRight = UBound(pvarArray, 1)
End If
lngFirst = plngLeft
lngLast = plngRight
lngIndex = plngRight - plngLeft + 1
a = Int(lngIndex * Rnd) + plngLeft
b = Int(lngIndex * Rnd) + plngLeft
c = Int(lngIndex * Rnd) + plngLeft
If pvarArray(a, iCol) <= pvarArray(b, iCol) And pvarArray(b, iCol) <= pvarArray(c, iCol) Then
lngIndex = b
Else
If pvarArray(b, iCol) <= pvarArray(a, iCol) And pvarArray(a, iCol) <= pvarArray(c, iCol) Then
lngIndex = a
Else
lngIndex = c
End If
End If
varMid = pvarArray(lngIndex, iCol)
Do
Do While pvarArray(lngFirst, iCol) > varMid And lngFirst < plngRight
lngFirst = lngFirst + 1
Loop
Do While varMid > pvarArray(lngLast, iCol) And lngLast > plngLeft
lngLast = lngLast - 1
Loop
If lngFirst <= lngLast Then
For j = LBound(pvarArray, 2) To UBound(pvarArray, 2)
varSwap = pvarArray(lngLast, j)
pvarArray(lngLast, j) = pvarArray(lngFirst, j)
pvarArray(lngFirst, j) = varSwap
Next j
lngFirst = lngFirst + 1
lngLast = lngLast - 1
End If
Loop Until lngFirst > lngLast
If (lngLast - plngLeft) < (plngRight - lngFirst) Then
If plngLeft < lngLast Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, plngLeft, lngLast
If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, lngFirst, plngRight
Else
If lngFirst < plngRight Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, lngFirst, plngRight
If plngLeft < lngLast Then MedianThreeQuickSort1_2D_Desc pvarArray, iCol, plngLeft, lngLast
End If
End Sub
sometimes the most brainless answer is the best answer.
tadaa. wont win you any programming prizes but it gets the job done fast.
I'm going to offer up a slight bit of different code to Steve's approach.
All valid points on efficiency, but to be frank.. when I was looking for a solution, I could have cared less about efficiency. Its VBA... I treat it like it deserves.
You want to sort a 2-d array. Plain simple dirty simple insert sort that will accept a variable size array and sort on a selected column.
Sub sort_2d_array(ByRef arrayin As Variant, colid As Integer)
'theWidth = LBound(arrayin, 2) - UBound(arrayin, 2)
For i = LBound(arrayin, 1) To UBound(arrayin, 1)
searchVar = arrayin(i, colid)
For ii = LBound(arrayin, 1) To UBound(arrayin, 1)
compareVar = arrayin(ii, colid)
If (CInt(searchVar) > CInt(compareVar)) Then
For jj = LBound(arrayin, 2) To UBound(arrayin, 2)
larger1 = arrayin(i, jj)
smaller1 = arrayin(ii, jj)
arrayin(i, jj) = smaller1
arrayin(ii, jj) = larger1
Next jj
i = LBound(arrayin, 1)
searchVar = arrayin(i, colid)
End If
Next ii
Next i
End Sub
For what it's worth (I can't show code at this point...let me see if I can edit it to post), I created an array of custom objects (so each of the properties come with whichever element its sorted by), populated a set of cells with each elements object properties of interest then used the excel sort function through vba to sort the column. Im sure theres probably a more efficient way of sorting it, rather than exporting it to cells, I just havent figured it out yet. This actually helped me a lot because when I needed to add a dimension, I just added a let and get property for the next dimension of the array.
You could make a separate array with 2 columns. Column 1 would be what your sorting on and 2 is what row is in other array. Sort this array by column 1 (only switching the two columns when swap). Then you could use the 2 arrays to process data as needed. Huge arrays could give you memory problems though
When sorting a multiple column array, I don't rearrange the elements. Instead I pass through another array S with the same number of elements, and number the items 1,2,3,....
Then I use the values in S as the index of the column to be sorted, and when I need to swap elements, I swap the values in S.
On returning from the sort, I can rearrange the original array if I need to, based on the sort sequence in S. It is quite easy to adapt quick sort to allow for this.
I have a similar array of Doubles to sort, so I've decided to write a native .dll.
For testing, I was using 64-bit integers, so you can use it for sorting the last dimension of Long and ULong arrays.
<DllImport("Arrayman.dll", EntryPoint:="SortLng")>
Sub sort(ByRef Array1stItem As Long, ByRef Indices1stItem As Integer, ByVal nItemsToSort As Long)
'Note: For sorting ULong integers, replace EntryPoint:="SortLng" with EntryPoint:="SortULng"
End Sub
In your example, you'd call it as
Dim idx(5)
sort(myArray(3,0), idx(0), idx.count)
to sort items from (3, 0) to (3, 5).
The lowest number is at myArray(3, idx(0)) and the highest at myArray(3, idx(5)).
ArrayMan.dll, more info and an example can be found on GitHub
