Attribute VB_Name = "MultiColumnSortExample"
Function SoSanh(a As Variant, r As Variant, i1 As Integer, i2 As Integer) As Integer
' compares two rows (i1 and i2) of an array a, using the rules array r
' returns: -1 if row i1 is less than row i2, 1 otherwise
Dim I As Integer, f As Integer, s As Integer
SoSanh = 0
For I = LBound(r) To UBound(r)
f = Abs(r(I)) ' column to compare
If a(i1, f) <> a(i2, f) Then
' note that Sgn(r(i)) tells whether the comparison is ascend/descending
If IsNumeric(a) And IsNumeric(b) Then
SoSanh = Sgn(r(I)) * IIf(Val(a(i1, f)) <> Val(a(i2, f)), -1, 1)
Else
SoSanh = Sgn(r(I)) * IIf(a(i1, f) < a(i2, f), -1, 1)
End If
Exit For ' no need to compare the next columns
End If
Next I
End Function
Sub sapxep()
Dim rg As Range
Set rg = Range("a3:g6707")
Dim ar As Variant, r(1 To 4) As Integer
Dim idx() As Integer
Dim rMx As Integer, cMx As Integer
ar = rg.Value
rMx = UBound(ar)
cMx = UBound(ar, 2)
r(1) = 1 ' column A ascending
r(2) = 2 ' column B ascending
r(3) = -3 ' column C desscending (negative value)
r(4) = 5 ' column E ascending
ReDim idx(1 To rMx)
' start sorting, using the index
Dim I As Integer, J As Integer, K As Integer
' create the index array
' the idea is that sorting the array directly will involve too much copying
' thus during soritng, only the indices are shuffled around
' when it's all done, copy the whole array according to the index array
For I = 1 To rMx
idx(I) = I
Next I
Debug.Print "start sorting"; Timer
' Demo with bubble sort, although any sort can do
'For I = 1 To rMx
' For J = I To rMx
' If SoSanh(ar, r, idx(J), idx(I)) < 0 Then
' K = idx(I)
' idx(I) = idx(J)
' idx(J) = K
' End If
' Next J
'Next I
Call QuickSort(ar, r, idx)
Debug.Print "start copying back"; Timer
' using the index array to copy back, line by line
Dim ar2 As Variant
ReDim ar2(1 To rMx, 1 To cMx)
For I = 1 To rMx
For J = 1 To cMx
ar2(I, J) = ar(idx(I), J)
Next J
Next I
rg.Value = ar2
Debug.Print "all done"; Timer
End Sub
Private Sub QuickSort(ByRef Values As Variant, ByRef Rules As Variant, ByRef IdxArray() As Integer, _
Optional ByVal Left As Long, Optional ByVal Right As Long)
' i (almost) always comment my codes
' however, this algorithim is too well known. I hope I can be excused this one time
Dim I As Long
Dim J As Long
Dim K As Long
Dim Item1 As Variant
Dim Item2 As Variant
On Error GoTo Catch
If IsMissing(Left) Or Left = 0 Then Left = LBound(IdxArray)
If IsMissing(Right) Or Right = 0 Then Right = UBound(IdxArray)
I = Left
J = Right
Item1 = IdxArray((Left + Right) \ 2)
Do While I < J
Do While SoSanh(Values, Rules, IdxArray(I), IdxArray(Item1)) < 0 And I < Right
I = I + 1
Loop
Do While SoSanh(Values, Rules, IdxArray(J), IdxArray(Item1)) > 0 And J > Left
J = J - 1
Loop
If I < J Then
K = IdxArray(I)
IdxArray(I) = IdxArray(J)
IdxArray(J) = K
End If
If I <= J Then
I = I + 1
J = J - 1
End If
Loop
If J > Left Then Call QuickSort(Values, Rules, IdxArray, Left, J)
If I < Right Then Call QuickSort(Values, Rules, IdxArray, I, Right)
Exit Sub
Catch:
MsgBox Err.Description, vbCritical
End Sub
