sbGSort

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”).
Please read my Disclaimer.
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

sbGrowthSeries

sbHighlightMinAdjacentCellsWhichSumUpToP

Last modified 2yr ago

Copy link