I don't know if this will help anybody, nor can I be sure this code is bullet proof, but what I can say is that I use it an awful lot to quickly sort arrays in VBA and I haven't broken it yet. Could be useful?
Nb. this mutates the original array so make a copy of your array first if you want one with the original order in place.
Code
- 'Sorts a one or two dimensional array.
- '2 dimensional arrays can have their sort keys specified by passing
- 'the appropriate column number(s) as the sortKeys parameter.
- 'Function passes a reference so will mutate your original array.
- 'If this is not desirable you must pass a copy.
- '
- 'Example uses:
- ' sortArray myArray - One-dimensional array
- ' sortArray myArray, 2 - Two-dimensional array, single sort key
- ' sortArray myArray, Array(2,3,1) - Two-dimensional array, multiple sort keys
- ' sortArray myArray, Array(2,3,1), True - Two-dimensional array, multiple sort keys with headers preserved
- Function UTIL_sortArray(ByRef arr As Variant, Optional ByRef sortKeys As Variant = Null, Optional ByVal hasHeaders As Boolean = False)
- Dim mid As Long
- Dim i As Long
- Dim j As Long
- Dim k As Long
- Dim x As Long
- Dim y As Long
- Dim sortMode As Long
- Dim arr1
- Dim arr2
- Dim head
- Dim tmp
- If UBound(arr) - LBound(arr) = 0 Then Exit Function
- On Error Resume Next
- i = UBound(arr, 2)
- If Err.Number <> 0 Then
- sortMode = 1 'Not a 2D array
- If hasHeaders Then
- ReDim tmp(LBound(arr) To UBound(arr) - 1)
- ReDim head(1 To 1)
- For i = LBound(arr) To UBound(arr)
- If i = LBound(arr) Then
- head(1) = arr(LBound(arr))
- Else
- tmp(i - 1) = arr(i)
- End If
- Next i
- arr = tmp
- End If
- Else
- sortMode = 2
- If hasHeaders Then
- ReDim tmp(LBound(arr) To (UBound(arr) - 1), LBound(arr, 2) To UBound(arr, 2))
- ReDim head(1 To 1, LBound(arr, 2) To UBound(arr, 2))
- For i = LBound(arr) To UBound(arr)
- For j = LBound(arr, 2) To UBound(arr, 2)
- If i = LBound(arr) Then
- head(1, j) = arr(LBound(arr), j)
- Else
- tmp(i - 1, j) = arr(i, j)
- End If
- Next j
- Next i
- arr = tmp
- End If
- End If
- On Error GoTo 0
- If IsNumeric(sortKeys) Then
- sortKeys = Array(CLng(sortKeys))
- ElseIf IsNull(sortKeys) Then
- sortKeys = Array(LBound(arr))
- End If
- y = LBound(sortKeys)
- mid = Int((UBound(arr) + IIf(LBound(arr) = 0, 1, 0)) / 2)
- If mid < LBound(arr) Then mid = LBound(arr)
- If sortMode = 1 Then
- ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0))
- ReDim arr2(LBound(arr) To UBound(arr) - mid)
- j = LBound(arr)
- For i = LBound(arr1) To UBound(arr1)
- arr1(i) = arr(j)
- j = j + 1
- Next i
- For i = LBound(arr2) To UBound(arr2)
- arr2(i) = arr(j)
- j = j + 1
- Next i
- ElseIf sortMode = 2 Then
- ReDim arr1(LBound(arr) To mid - IIf(LBound(arr) = 0, 1, 0), LBound(arr, 2) To UBound(arr, 2))
- ReDim arr2(LBound(arr) To UBound(arr) - mid, LBound(arr, 2) To UBound(arr, 2))
- j = LBound(arr)
- For i = LBound(arr1) To UBound(arr1)
- For k = LBound(arr1, 2) To UBound(arr1, 2)
- arr1(i, k) = arr(j, k)
- Next k
- j = j + 1
- Next i
- For i = LBound(arr2) To UBound(arr2)
- For k = LBound(arr2, 2) To UBound(arr2, 2)
- arr2(i, k) = arr(j, k)
- Next k
- j = j + 1
- Next i
- End If
- UTIL_sortArray arr1, sortKeys 'I call myself!!!
- UTIL_sortArray arr2, sortKeys 'I call myself again!!!
- i = LBound(arr)
- j = LBound(arr1)
- k = LBound(arr2)
- If sortMode = 1 Then
- While j <= UBound(arr1) And k <= UBound(arr2)
- If arr1(j) <= arr2(k) Then
- arr(i) = arr1(j)
- j = j + 1
- Else
- arr(i) = arr2(k)
- k = k + 1
- End If
- i = i + 1
- Wend
- While j <= UBound(arr1)
- arr(i) = arr1(j)
- j = j + 1
- i = i + 1
- Wend
- While k <= UBound(arr2)
- arr(i) = arr2(k)
- k = k + 1
- i = i + 1
- Wend
- ElseIf sortMode = 2 Then
- While j <= UBound(arr1) And k <= UBound(arr2)
- If arr1(j, sortKeys(y)) < arr2(k, sortKeys(y)) _
- Or (arr1(j, sortKeys(y)) = arr2(k, sortKeys(y)) And UBound(sortKeys) = y) Then
- For x = LBound(arr1, 2) To UBound(arr1, 2)
- arr(i, x) = arr1(j, x)
- Next x
- j = j + 1
- y = LBound(sortKeys)
- ElseIf arr1(j, sortKeys(y)) > arr2(k, sortKeys(y)) Then
- For x = LBound(arr2, 2) To UBound(arr2, 2)
- arr(i, x) = arr2(k, x)
- Next x
- k = k + 1
- y = LBound(sortKeys)
- Else
- i = i - 1
- y = y + 1
- End If
- i = i + 1
- Wend
- While j <= UBound(arr1)
- For x = LBound(arr1, 2) To UBound(arr1, 2)
- arr(i, x) = arr1(j, x)
- Next x
- j = j + 1
- i = i + 1
- Wend
- While k <= UBound(arr2)
- For x = LBound(arr2, 2) To UBound(arr2, 2)
- arr(i, x) = arr2(k, x)
- Next x
- k = k + 1
- i = i + 1
- Wend
- End If
- If hasHeaders Then
- If sortMode = 1 Then
- '1d
- ReDim tmp(LBound(tmp) To UBound(tmp) + 1)
- tmp(LBound(tmp)) = head(1)
- For i = LBound(arr) To UBound(arr)
- tmp(i + 1) = arr(i)
- Next i
- Else
- '2d
- ReDim tmp(LBound(tmp) To UBound(tmp) + 1, LBound(tmp, 2) To UBound(tmp, 2))
- For i = LBound(tmp) To UBound(tmp)
- For j = LBound(tmp, 2) To UBound(tmp, 2)
- If i = LBound(tmp) Then
- tmp(i, j) = head(1, j)
- Else
- tmp(i, j) = arr(i - 1, j)
- End If
- Next
- Next i
- End If
- arr = tmp
- End If
- End Function