Quick Sort for 2D Array Multiple Column Sort Ascending Descending and Transposed

[Natas]

I got tired of searching for a Quick Sort version that would do a 2D array, sort multiple columns, sort by ascending and descending order, and also handle a transposed array so I wrote my own. I thought I'd share.
It uses the existing QuickSort sub that is found on the web and adds the above features to it.

Call it from within another sub
Example:
Call QuickSort2D(Arr, "1,A,3,D,2,A",lbound(arr),ubound(arr))

Add optional Yaxis parameter on the end set to 2 if your Array is transposed.
The "1,A,3,D,2,A" stands for sorting Column1 Ascending, Column3 Descending, Column2 Ascending

Tested using an array 37385x22 sorting 3 columns and took 2 seconds.

''''''''''''''''''''
Sub QuickSort2D(Arr, Crit As String, arrLbound As Long, arrUbound As Long, Optional Yaxis As Integer = 1)
Dim i As Integer, a As Integer
Dim Cr

Cr = Split(Crit, ",")
a = (UBound(Cr) - 1) / 2
ReDim Col(0 To a)
ReDim AorD(0 To a)
a = 0
For i = LBound(Cr) To UBound(Cr) Step 2
Col(a) = Cr(i)
AorD(a) = Cr(i + 1)
a = a + 1
Next i

Call QuicksortCalc(Arr, Col, AorD, arrLbound, arrUbound, Yaxis)

End Sub

Sub QuicksortCalc(varray As Variant, Col, AorD, arrLbound As Long, arrUbound As Long, Yaxis As Integer)
Dim pivotVal As Variant
Dim vSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
Dim i As Integer
Dim Pval

tmpLow = arrLbound
tmpHi = arrUbound

Pval = Col
If Yaxis = 1 Then
For i = LBound(Pval) To UBound(Pval)
Pval(i) = varray((arrLbound + arrUbound) \ 2, Col(i))
Next i
Else
For i = LBound(Pval) To UBound(Pval)
Pval(i) = varray(Col(i), (arrLbound + arrUbound) \ 2)
Next i
End If

While (tmpLow <= tmpHi)

While Checkstr1(varray, tmpLow, Col, AorD, Pval, Yaxis) And tmpLow < arrUbound
tmpLow = tmpLow + 1
Wend


While Checkstr2(varray, tmpHi, Col, AorD, Pval, Yaxis) And tmpHi > arrLbound
tmpHi = tmpHi - 1
Wend

If (tmpLow <= tmpHi) Then
If Yaxis = 1 Then
For i = LBound(varray, 2) To UBound(varray, 2)
vSwap = varray(tmpLow, i)
varray(tmpLow, i) = varray(tmpHi, i)
varray(tmpHi, i) = vSwap
Next i
Else
For i = LBound(varray) To UBound(varray)
vSwap = varray(i, tmpLow)
varray(i, tmpLow) = varray(i, tmpHi)
varray(i, tmpHi) = vSwap
Next i
End If
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend

If (arrLbound < tmpHi) Then QuicksortCalc varray, Col, AorD, arrLbound, tmpHi, Yaxis
If (tmpLow < arrUbound) Then QuicksortCalc varray, Col, AorD, tmpLow, arrUbound, Yaxis

End Sub

Function Checkstr1(varray, tmpLow, Col, AorD, Pval, Yaxis) As Boolean
Dim i As Integer
Dim Str1 As Variant

For i = LBound(Pval) To UBound(Pval)
If Yaxis = 1 Then Str1 = varray(tmpLow, Col(i)) Else Str1 = varray(Col(i), tmpLow)

If StrComp(AorD(i), "A", 1) = 0 Then
If Str1 < Pval(i) Then Checkstr1 = True: Exit Function
If Str1 > Pval(i) Then Exit Function
Else
If Str1 > Pval(i) Then Checkstr1 = True: Exit Function
If Str1 < Pval(i) Then Exit Function
End If
Next i

End Function

Function Checkstr2(varray, tmpHi, Col, AorD, Pval, Yaxis) As Boolean
Dim i As Integer
Dim Str1 As Variant

For i = LBound(Pval) To UBound(Pval)
If Yaxis = 1 Then Str1 = varray(tmpHi, Col(i)) Else Str1 = varray(Col(i), tmpHi)

If StrComp(AorD(i), "A", 1) = 0 Then
If Pval(i) < Str1 Then Checkstr2 = True: Exit Function
If Pval(i) > Str1 Then Exit Function
Else
If Pval(i) > Str1 Then Checkstr2 = True: Exit Function
If Pval(i) < Str1 Then Exit Function
End If
Next i

End Function
''''''''''''''''''''''''''''''''''

 

[Natas]

Nice idea using a Dictionary for sorting.
On my previous post, did you run the sort in reverse order?
Meaning if I wanted to sort the array by column1 A, column2 A, column3 D. I would run the order backwards calling the sort each time.

    Set rnga = Sheets("Sheet1").Range("A1").CurrentRegion
    arr1 = rnga.Offset(1, 0).Resize(rnga.Rows.Count - 1, rnga.Columns.Count)
    arr2 = Application.Sort(arr1, 3, -1)
    arr1 = Application.Sort(arr2, 2)
    arr2 = Application.Sort(arr1, 1)

This would be the equivalent to sorting within the worksheet without moving it into an array like below.

Range("A1").CurrentRegion.Sort key1:=Range("C1"), Order1:=xlDescending, Header:=xlYes
Range("A1").CurrentRegion.Sort key1:=Range("B1"), Order1:=xlAscending, Header:=xlYes
Range("A1").CurrentRegion.Sort key1:=Range("A1"), Order1:=xlAscending, Header:=xlYes

On Left, unsorted. On the right sorted. Both methods produce the correct results.

ItemID Date PPID ItemID Date PPID
F1 5/25/2022 100 F1 4/28/2022 10
F1 5/26/2022 66 F1 5/21/2022 61
F1 5/21/2022 100 F1 5/25/2022 100
F1 6/10/2022 92 F1 5/25/2022 6
F1 5/25/2022 49 F1 5/26/2022 75
F1 4/28/2022 13 F1 6/10/2022 20
F7 4/28/2022 7 F18 5/29/2022 33
F7 5/21/2022 32 F19 5/25/2022 95
F7 4/28/2022 51 F2 5/25/2022 21
F7 5/25/2022 25 F2 5/26/2022 47
F7 6/10/2022 66 F2 5/27/2022 75
F7 6/10/2022 86 F2 5/28/2022 80
F2 6/10/2022 88 F2 6/10/2022 21
F2 5/25/2022 65 F22 5/21/2022 38
F2 5/26/2022 57 F22 5/26/2022 0
F2 5/27/2022 92 F22 6/10/2022 61
F2 5/28/2022 86 F22 8/1/2022 47
F18 5/29/2022 2 F7 4/28/2022 78
F19 5/25/2022 5 F7 4/28/2022 17
F22 5/21/2022 3 F7 5/21/2022 59
F22 8/1/2022 55 F7 5/25/2022 42
F22 5/26/2022 97 F7 6/10/2022 93
F22 6/10/2022 75 F7 6/10/2022 72

 

[Natas]

Use the StrCmpLogicalW function to sort strings in numerical order:

#If VBA7 Then
    Private Declare PtrSafe Function StrCmpLogicalW Lib "shlwapi.dll" (ByVal string1 As String, ByVal string2 As String) As Long
#Else
    PrivateDeclare Function StrCmpLogicalW Lib "shlwapi.dll" (ByVal string1 As String, ByVal string2 As String) As Long
#End If

Sub test()
    Dim string1 As String, string2 As String
    string1 = "300": string2 = "77"
    If StrCmpLogicalW(string1, string2) = 1 Then
        MsgBox string1 & " > " & string2
    End If
End Sub

Thank you for this. Another gem I didn't know about. Both you guys are pros!

 

[BSALV]

you can also copy the array to a new added worksheet, sort there with the available methods, read the results to (another) array and delete the new added worksheet, within 1 seconde and 5 combined keys !

Sub Sort_Within_Worksheet()

     arr = WorksheetFunction.RandArray(100000, 5, 1, 10, 1)     '100.000 rows * 5 columns in an arry

     t = Timer     'start chrono

     Application.ScreenUpdating = False
     With ThisWorkbook.Worksheets.Add     'add a new worksheet
          .Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr     'write to sheet
          Set myrange = .UsedRange     'this range
          With myrange.Parent.Sort
               .SortFields.Clear
               For i = 1 To 5     ' sort 3 times descending and 2 times ascending
                    .SortFields.Add2 Key:=myrange.Columns(i), SortOn:=xlSortOnValues, Order:=IIf(i Mod 2, xlDescending, xlAscending), DataOption:=xlSortNormal
               Next
               .SetRange myrange
               .Header = xlNo     'you can choice with or without header
               .MatchCase = False
               .Orientation = xlTopToBottom
               .SortMethod = xlPinYin
               .Apply
          End With
          arr1 = myrange.Value     'read the result again to (another) array
          Application.DisplayAlerts = False
          .Delete     'delete the new added worksheet
          Application.DisplayAlerts = True
     End With

     MsgBox "time elapsed : " & Format(Timer - t, "0.0\s")
End Sub

 

[Natas]

Thanks so much for all the different ideas and ways you have shown me. You are a pro!

 

[Fibo]

I got tired of searching for a Quick Sort version that would do a 2D array, sort multiple columns, sort by ascending and descending order, and also handle a transposed array so I wrote my own. I thought I'd share.
It uses the existing QuickSort sub that is found on the web and adds the above features to it.

Call it from within another sub
Example:
Call QuickSort2D(Arr, "1,A,3,D,2,A",lbound(arr),ubound(arr))

Add optional Yaxis parameter on the end set to 2 if your Array is transposed.
The "1,A,3,D,2,A" stands for sorting Column1 Ascending, Column3 Descending, Column2 Ascending

Tested using an array 37385x22 sorting 3 columns and took 2 seconds.

''''''''''''''''''''
Sub QuickSort2D(Arr, Crit As String, arrLbound As Long, arrUbound As Long, Optional Yaxis As Integer = 1)
Dim i As Integer, a As Integer
Dim Cr

Cr = Split(Crit, ",")
a = (UBound(Cr) - 1) / 2
ReDim Col(0 To a)
ReDim AorD(0 To a)
a = 0
For i = LBound(Cr) To UBound(Cr) Step 2
Col(a) = Cr(i)
AorD(a) = Cr(i + 1)
a = a + 1
Next i

Call QuicksortCalc(Arr, Col, AorD, arrLbound, arrUbound, Yaxis)

End Sub

Sub QuicksortCalc(varray As Variant, Col, AorD, arrLbound As Long, arrUbound As Long, Yaxis As Integer)
Dim pivotVal As Variant
Dim vSwap As Variant
Dim tmpLow As Long
Dim tmpHi As Long
Dim i As Integer
Dim Pval

tmpLow = arrLbound
tmpHi = arrUbound

Pval = Col
If Yaxis = 1 Then
For i = LBound(Pval) To UBound(Pval)
Pval(i) = varray((arrLbound + arrUbound) \ 2, Col(i))
Next i
Else
For i = LBound(Pval) To UBound(Pval)
Pval(i) = varray(Col(i), (arrLbound + arrUbound) \ 2)
Next i
End If

While (tmpLow <= tmpHi)

While Checkstr1(varray, tmpLow, Col, AorD, Pval, Yaxis) And tmpLow < arrUbound
tmpLow = tmpLow + 1
Wend


While Checkstr2(varray, tmpHi, Col, AorD, Pval, Yaxis) And tmpHi > arrLbound
tmpHi = tmpHi - 1
Wend

If (tmpLow <= tmpHi) Then
If Yaxis = 1 Then
For i = LBound(varray, 2) To UBound(varray, 2)
vSwap = varray(tmpLow, i)
varray(tmpLow, i) = varray(tmpHi, i)
varray(tmpHi, i) = vSwap
Next i
Else
For i = LBound(varray) To UBound(varray)
vSwap = varray(i, tmpLow)
varray(i, tmpLow) = varray(i, tmpHi)
varray(i, tmpHi) = vSwap
Next i
End If
tmpLow = tmpLow + 1
tmpHi = tmpHi - 1
End If
Wend

If (arrLbound < tmpHi) Then QuicksortCalc varray, Col, AorD, arrLbound, tmpHi, Yaxis
If (tmpLow < arrUbound) Then QuicksortCalc varray, Col, AorD, tmpLow, arrUbound, Yaxis

End Sub

Function Checkstr1(varray, tmpLow, Col, AorD, Pval, Yaxis) As Boolean
Dim i As Integer
Dim Str1 As Variant

For i = LBound(Pval) To UBound(Pval)
If Yaxis = 1 Then Str1 = varray(tmpLow, Col(i)) Else Str1 = varray(Col(i), tmpLow)

If StrComp(AorD(i), "A", 1) = 0 Then
If Str1 < Pval(i) Then Checkstr1 = True: Exit Function
If Str1 > Pval(i) Then Exit Function
Else
If Str1 > Pval(i) Then Checkstr1 = True: Exit Function
If Str1 < Pval(i) Then Exit Function
End If
Next i

End Function

Function Checkstr2(varray, tmpHi, Col, AorD, Pval, Yaxis) As Boolean
Dim i As Integer
Dim Str1 As Variant

For i = LBound(Pval) To UBound(Pval)
If Yaxis = 1 Then Str1 = varray(tmpHi, Col(i)) Else Str1 = varray(Col(i), tmpHi)

If StrComp(AorD(i), "A", 1) = 0 Then
If Pval(i) < Str1 Then Checkstr2 = True: Exit Function
If Pval(i) > Str1 Then Exit Function
Else
If Pval(i) > Str1 Then Checkstr2 = True: Exit Function
If Pval(i) < Str1 Then Exit Function
End If
Next i

End Function
''''''''''''''''''''''''''''''''''

So nice. Thank you. It works perfectly and it is fast.