sbGSort
Take worksheet function SORT from Excel 365 onwards
If you look for a simple Excel © VBA sort function which you can easily apply on small ranges or arrays then you are at the right place. If you are not willing or if you are not able to use VBA macros, look here, please.
The parameters of sbGSort I chose pragmatically but not without care. If you call this function with sbGSort(...,”AD”,”SN”,”31”) then A(scending order) and S(tring comparison) will be applied on column 3 (the first priority column to sort by). It's not very convenient if you change the column priority from “31” to “13” that you will have to change the order of “AD” (to “DA”) and “SN” (to “NS”) as well. On the other hand, you won't need to state all sOrd and sCT characters up to column 9 if you call GSort with (...,”A”,”S”,”9”).
Function sbGSort(vA As Variant, _
Optional sOrd As String = "A", _
Optional sCT As String = "S", _
Optional sPrio As String = "123456789") As Variant
'Performs a gnomesort on one- or two-dimensional array vA.
'Characters in sOrd define sort order for each column:
'A - ascending, D - descending
'Characters in sCT define comparison type for each column:
'S - string, N - numerical
'Characters in sPrio define sort priorities of columns, for
'example:
'123 - sort by first, then second, then third column
'521 - sort by fifth, then second, then first column
'Note that the maximum count of characters in sOrd or sPrio
'defines on how many columns the sort comparisons will be
'applied. If sOrd = "AAAA" and sPrio = "3", for example, the
'sort comparison will be on the four columns 3 1 2 4 in this
'order.
'Please note that this is a fairly weak sort algorithm
'because its sort time is expected to be quadratic. But its
'supposed to be used on small ranges or arrays only.
'Larger ranges or arrays should be sorted by Excel's internal
'sort algorithm via a subroutine.
'Reverse("moc.LiborPlus.www") PB 07-Mar-2009 V0.11
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim n As Long
Dim v As Variant
Dim vT As Variant
Dim sComparisonType As String
Dim sSortOrder As String
Dim lPrio As Long
Dim sC As String
Dim bSwap As Boolean 'Indicates whether we need to swap rows
Dim bOrd As Boolean 'FALSE = Ascending sort order
Dim obj As Object
With Application.WorksheetFunction
vT = .Transpose(.Transpose(vA))
m = UBound(vT, 1)
n = UBound(vT, 2)
lPrio = .Min(n, .Max(Len(sOrd), Len(sPrio)))
'Process sort priorities of columns (if given)
Set obj = CreateObject("Scripting.Dictionary")
If Len(sPrio) < 1 Then
sbGSort = CVErr(xlErrValue)
Exit Function
End If
ReDim lPriority(1 To lPrio) As Long
i = 1
j = 1
Do While i <= lPrio
If i <= Len(sPrio) Then
sC = Mid(sPrio, i, 1)
Select Case sC
Case "1", "2", "3", "4", "5", "6", "7", "8", "9"
lPriority(i) = Asc(sC) - Asc("0")
obj.Item(lPriority(i)) = i
Case Else
sbGSort = CVErr(xlErrValue)
Exit Function
End Select
Else
Do While obj.Item(j) > 0
j = j + 1
Loop
lPriority(i) = j
obj.Item(j) = i
End If
i = i + 1
Loop
Set obj = Nothing
'Process sort order for each column (if given)
If Len(sOrd) < 1 Then
sbGSort = CVErr(xlErrValue)
Exit Function
End If
For i = 1 To lPrio
If i > Len(sOrd) Then
sC = "A"
Else
sC = Mid(sOrd, i, 1)
If sC <> "A" And sC <> "D" Then
sbGSort = CVErr(xlErrValue)
Exit Function
End If
End If
sSortOrder = sSortOrder & sC
Next i
'Process comparison type for each column
If Len(sCT) < 1 Then
sbGSort = CVErr(xlErrValue)
Exit Function
End If
For i = 1 To n
If i <= lPrio Then
k = lPriority(i)
Else
k = i
End If
If i <= Len(sCT) Then
sC = Mid(sCT, i, 1)
End If
For j = 1 To m
Select Case sC
Case "N"
If IsEmpty(vT(j, k)) Then vT(j, k) = 0
Case "S"
If IsEmpty(vT(j, k)) Then vT(j, k) = ""
Case Else
sbGSort = CVErr(xlErrValue)
Exit Function
End Select
Next j
sComparisonType = sComparisonType & sC
Next i
i = 1
Do While i < m
'Compare row i with row i+1
j = 1
bSwap = False
Do While j <= lPrio
If Mid(sSortOrder, j, 1) = "A" Then
bOrd = False
Else
bOrd = True
End If
If Mid(sComparisonType, j, 1) = "N" Then
If vT(i, lPriority(j)) + 0 > _
vT(i + 1, lPriority(j)) + 0 Then
bSwap = True Xor bOrd
Exit Do
ElseIf vT(i, lPriority(j)) + 0 < _
vT(i + 1, lPriority(j)) + 0 Then
bSwap = False Xor bOrd
Exit Do
End If
Else
If vT(i, lPriority(j)) & "" > vT(i + 1, _
lPriority(j)) & "" Then
bSwap = True Xor bOrd
Exit Do
ElseIf vT(i, lPriority(j)) & "" < vT(i + _
1, lPriority(j)) & "" Then
bSwap = False Xor bOrd
Exit Do
End If
End If
j = j + 1
Loop
If bSwap Then
For j = 1 To n
v = vT(i, j)
vT(i, j) = vT(i + 1, j)
vT(i + 1, j) = v
Next j
If i > 1 Then
i = i - 1
Else
i = i + 1
End If
Else
i = i + 1
End If
Loop
End With
sbGSort = vT
End Function
Last modified 2yr ago