Option Explicit
Public imageArray As Variant
Public keyCol As Long, keyCol2
Function QSortedArray(ByVal inputRange As Variant, Optional keyColumn As Long, Optional keyColumn2 As Long, Optional Descending As Boolean) As Variant
Dim RowArray As Variant
Dim outRRay As Variant
Dim i As Long, j As Long, size As Long
If keyColumn = 0 Then keyColumn = 1
Rem Input array vs range handeling
On Error GoTo HaltFunction
Select Case TypeName(inputRange)
Case Is = "Range"
If inputRange.Columns.Count < keyColumn Then
QSortedArray = CVErr(xlErrRef): Exit Function
Else
Set inputRange = Application.Intersect(inputRange, inputRange.Parent.UsedRange)
If inputRange Is Nothing Then
QSortedArray = Array(vbNullString): Exit Function
Else
imageArray = inputRange.Value
End If
End If
Case Is = "Variant()", "String()", "Double()", "Long()"
If UBound(inputRange, 2) < keyColumn Then
QSortedArray = Array(CVErr(xlErrRef)): Exit Function
Else
imageArray = inputRange
End If
Case Else
QSortedArray = CVErr(xlErrNA): Exit Function
End Select
On Error GoTo 0
Rem pass arguments To Public variables
If keyColumn2 = 0 Then keyColumn2 = keyColumn
If UBound(imageArray, 2) < keyColumn Then QSortedArray = CVErr(xlErrRef): Exit Function
If UBound(imageArray, 2) < keyColumn2 Then QSortedArray = CVErr(xlErrRef): Exit Function
keyCol = keyColumn
keyCol2 = keyColumn2
Rem create array of row numbers {1,2,3,...,Rows.Count}
size = UBound(imageArray, 1)
ReDim RowArray(1 To size)
For i = 1 To size
RowArray(i) = i
Next i
Rem sort row numbers
Call sortQuickly(RowArray, Descending)
Rem read imageArray With row order per the sorted RowArray
ReDim outRRay(1 To size, 1 To UBound(imageArray, 2))
For i = 1 To size
For j = 1 To UBound(outRRay, 2)
outRRay(i, j) = imageArray(RowArray(i), j)
Next j
Next i
QSortedArray = outRRay
Erase imageArray
HaltFunction:
On Error GoTo 0
End Function
Sub sortQuickly(ByRef inRRay As Variant, Optional ByVal Descending As Boolean, Optional ByVal low As Long, Optional ByVal high As Long)
Dim pivot As Variant
Dim i As Long, pointer As Long
If low = 0 Then low = LBound(inRRay)
If high = 0 Then high = UBound(inRRay)
pointer = low
Call Swap(inRRay, (low + high) / 2, high)
pivot = inRRay(high)
For i = low To high - 1
If LT(inRRay(i), pivot) Xor Descending Then
Call Swap(inRRay, i, pointer)
pointer = pointer + 1
End If
Next i
Call Swap(inRRay, pointer, high)
If low < pointer - 1 Then
Call sortQuickly(inRRay, Descending, low, pointer - 1)
End If
If pointer + 1 <= high Then
Call sortQuickly(inRRay, Descending, pointer + 1, high)
End If
End Sub
Function LT(aRow As Variant, bRow As Variant, Optional Descending As Boolean) As Boolean
On Error GoTo HaltFtn
LT = Descending
If imageArray(aRow, keyCol) = imageArray(bRow, keyCol) Then
LT = imageArray(aRow, keyCol2) < imageArray(bRow, keyCol2)
Else
LT = (imageArray(aRow, keyCol) < imageArray(bRow, keyCol))
End If
HaltFtn:
On Error GoTo 0
End Function
Sub Swap(ByRef inRRay, a As Long, b As Long)
Dim temp As Variant
temp = inRRay(a)
inRRay(a) = inRRay(b)
inRRay(b) = temp
End Sub
QSortedArray can either be entered as an array formula on a spreadsheet, or used in a VB routine to return a sorted array.
Bookmarks