Sulprobil
Search…
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”).
1
Function sbGSort(vA As Variant, _
2
Optional sOrd As String = "A", _
3
Optional sCT As String = "S", _
4
Optional sPrio As String = "123456789") As Variant
5
'Performs a gnomesort on one- or two-dimensional array vA.
6
'Characters in sOrd define sort order for each column:
7
'A - ascending, D - descending
8
'Characters in sCT define comparison type for each column:
9
'S - string, N - numerical
10
'Characters in sPrio define sort priorities of columns, for
11
'example:
12
'123 - sort by first, then second, then third column
13
'521 - sort by fifth, then second, then first column
14
'Note that the maximum count of characters in sOrd or sPrio
15
'defines on how many columns the sort comparisons will be
16
'applied. If sOrd = "AAAA" and sPrio = "3", for example, the
17
'sort comparison will be on the four columns 3 1 2 4 in this
18
'order.
19
'Please note that this is a fairly weak sort algorithm
20
'because its sort time is expected to be quadratic. But its
21
'supposed to be used on small ranges or arrays only.
22
'Larger ranges or arrays should be sorted by Excel's internal
23
'sort algorithm via a subroutine.
24
'Reverse("moc.LiborPlus.www") PB 07-Mar-2009 V0.11
25
Dim i As Long
26
Dim j As Long
27
Dim k As Long
28
Dim m As Long
29
Dim n As Long
30
Dim v As Variant
31
Dim vT As Variant
32
Dim sComparisonType As String
33
Dim sSortOrder As String
34
Dim lPrio As Long
35
Dim sC As String
36
Dim bSwap As Boolean 'Indicates whether we need to swap rows
37
Dim bOrd As Boolean 'FALSE = Ascending sort order
38
Dim obj As Object
39
40
With Application.WorksheetFunction
41
vT = .Transpose(.Transpose(vA))
42
m = UBound(vT, 1)
43
n = UBound(vT, 2)
44
lPrio = .Min(n, .Max(Len(sOrd), Len(sPrio)))
45
46
'Process sort priorities of columns (if given)
47
Set obj = CreateObject("Scripting.Dictionary")
48
If Len(sPrio) < 1 Then
49
sbGSort = CVErr(xlErrValue)
50
Exit Function
51
End If
52
ReDim lPriority(1 To lPrio) As Long
53
i = 1
54
j = 1
55
Do While i <= lPrio
56
If i <= Len(sPrio) Then
57
sC = Mid(sPrio, i, 1)
58
Select Case sC
59
Case "1", "2", "3", "4", "5", "6", "7", "8", "9"
60
lPriority(i) = Asc(sC) - Asc("0")
61
obj.Item(lPriority(i)) = i
62
Case Else
63
sbGSort = CVErr(xlErrValue)
64
Exit Function
65
End Select
66
Else
67
Do While obj.Item(j) > 0
68
j = j + 1
69
Loop
70
lPriority(i) = j
71
obj.Item(j) = i
72
End If
73
i = i + 1
74
Loop
75
Set obj = Nothing
76
77
'Process sort order for each column (if given)
78
If Len(sOrd) < 1 Then
79
sbGSort = CVErr(xlErrValue)
80
Exit Function
81
End If
82
For i = 1 To lPrio
83
If i > Len(sOrd) Then
84
sC = "A"
85
Else
86
sC = Mid(sOrd, i, 1)
87
If sC <> "A" And sC <> "D" Then
88
sbGSort = CVErr(xlErrValue)
89
Exit Function
90
End If
91
End If
92
sSortOrder = sSortOrder & sC
93
Next i
94
95
'Process comparison type for each column
96
If Len(sCT) < 1 Then
97
sbGSort = CVErr(xlErrValue)
98
Exit Function
99
End If
100
For i = 1 To n
101
If i <= lPrio Then
102
k = lPriority(i)
103
Else
104
k = i
105
End If
106
If i <= Len(sCT) Then
107
sC = Mid(sCT, i, 1)
108
End If
109
For j = 1 To m
110
Select Case sC
111
Case "N"
112
If IsEmpty(vT(j, k)) Then vT(j, k) = 0
113
Case "S"
114
If IsEmpty(vT(j, k)) Then vT(j, k) = ""
115
Case Else
116
sbGSort = CVErr(xlErrValue)
117
Exit Function
118
End Select
119
Next j
120
sComparisonType = sComparisonType & sC
121
Next i
122
123
i = 1
124
Do While i < m
125
126
'Compare row i with row i+1
127
j = 1
128
bSwap = False
129
Do While j <= lPrio
130
If Mid(sSortOrder, j, 1) = "A" Then
131
bOrd = False
132
Else
133
bOrd = True
134
End If
135
If Mid(sComparisonType, j, 1) = "N" Then
136
If vT(i, lPriority(j)) + 0 > _
137
vT(i + 1, lPriority(j)) + 0 Then
138
bSwap = True Xor bOrd
139
Exit Do
140
ElseIf vT(i, lPriority(j)) + 0 < _
141
vT(i + 1, lPriority(j)) + 0 Then
142
bSwap = False Xor bOrd
143
Exit Do
144
End If
145
Else
146
If vT(i, lPriority(j)) & "" > vT(i + 1, _
147
lPriority(j)) & "" Then
148
bSwap = True Xor bOrd
149
Exit Do
150
ElseIf vT(i, lPriority(j)) & "" < vT(i + _
151
1, lPriority(j)) & "" Then
152
bSwap = False Xor bOrd
153
Exit Do
154
End If
155
End If
156
j = j + 1
157
Loop
158
159
If bSwap Then
160
For j = 1 To n
161
v = vT(i, j)
162
vT(i, j) = vT(i + 1, j)
163
vT(i + 1, j) = v
164
Next j
165
If i > 1 Then
166
i = i - 1
167
Else
168
i = i + 1
169
End If
170
Else
171
i = i + 1
172
End If
173
174
Loop
175
176
End With
177
178
sbGSort = vT
179
180
End Function
Copied!
Last modified 2yr ago
Copy link