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

N

Natas

New Member
Joined
May 24, 2022
Messages
17
Office Version
  1. 365
Platform
  1. Windows
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
''''''''''''''''''''''''''''''''''
 
Sort by date Sort by votes
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.

VBA Code: 
    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.

Code: 
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
 
Upvote 0

Excel Facts

Why are there 1,048,576 rows in Excel?
The Excel team increased the size of the grid in 2007. There are 2^20 rows and 2^14 columns for a total of 17 billion cells.
John_w said:
Use the StrCmpLogicalW function to sort strings in numerical order:

VBA Code: 
#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
Click to expand...
Thank you for this. Another gem I didn't know about. Both you guys are pros!
 
Upvote 0
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 !
VBA Code: 
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
 
Upvote 0
Thanks so much for all the different ideas and ways you have shown me. You are a pro!
 
Upvote 0
Natas said:
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
''''''''''''''''''''''''''''''''''
Click to expand...
So nice. Thank you. It works perfectly and it is fast.
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question Question
Function to return array of 10 largest absolute values while maintaining sign
Replies
3
Views
534
eurobonds
E
R
  • Solved
Determine unique values on a filtered column in a table
Replies
3
Views
756
Domenic
D
W
  • Solved
Runtime Error 5 on very complicated sheet (to me anyway :) )
2 3
Replies
26
Views
3K
Woodpusher147
W
T
  • Question Question
Quicksort
Replies
5
Views
4K
Fluff
Fluff
V
  • Question Question
VBA pivot filter with array value for multiple criteria
Replies
0
Views
498
VenkateshRajaganesan
V

Forum statistics

Threads
1,223,237
Messages
6,170,924
Members
452,366
Latest member
TePunaBloke

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top