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

Natas · May 24, 2022

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
''''''''''''''''''''''''''''''''''

johnnyL · May 24, 2022

Welcome to the mrexcel @Natas.

Thank you for the offering.

I don't see where you display the results from the sorted array though.

BSALV · May 24, 2022

excel365 (and 2021?) has it own sort-function for 2D-arrays ascending, descending but with only 1 key (!)

VBA Code:

Sub SortArrays()
     arr1 = ActiveSheet.Range("A1").CurrentRegion
     arr2 = Application.Sort(arr1, 3, -1)
     Range("E1").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2
End Sub

Natas · May 24, 2022

Sorry, here is a small sample of the 35k rows ran with column1 Asc, column3 Desc, and column2 Asc skipping the header of course.
Call QuickSort2D(Arr, "1,A,3,D,2,A",lbound(arr)+1,ubound(arr))

The only thing I've noticed since I've created it, it doesn't sort numbers correctly. If the Item's say were just a serial numbers, it would sort a 300 lower 77. Any tips?

Item	TranType	Date	PDQty	SOQty	SOSfQty	BB	BBSfty	D/O	D/Oadj	ALL-PD	BB-SO	ALL-SO	ALL-SOSF	Cast	AB-PD	AB-SO	AB-ALLSO	AB-SOSR	Desc	Onorder	Date	Item	TranType	Date
F7	PMT	05/20/2022	-10523.34	-10523.34	-10523.34	34	34			-10523	-10523	-10523	-10523	HEATXC	-21863	-21863	-21863	-21863		19821	5/31/2022	HMSRD	PMT	05/20/2022
F18	PM	05/20/2022	-7326.27	-7326.27	-7326.27	34	34			-7292	-7292	-7292	-7292	HEATXC	-7292	-7292	-7292	-7292		19821	5/31/2022	H3SK	PMT	05/20/2022
F17	PM	05/21/2022	-6608	-6608	-6608	5439	5439			-1169	-1169	-1169	-1169	F6909	-1169	-1169	-1169	-1169		10000	6/9/2022	L8RFIP	PMT	05/20/2022
F17	PM	05/22/2022	-8255	-8255	-8255	12117	12117			0	0	0	0	C1360	3862	3862	3862	3862				LGP3	PMT	05/20/2022
F25	PMT	05/23/2022	-5491.4508	-5491.4508	-5491.4508	14478	8478			0	0	0	0	C1021	2987	8987	2987	2987				L10SK3	PMT	05/20/2022
F2	PMT	05/24/2022	-7170.6162	-7170.6162	-7170.6162	18668	11168			0	0	0	0	C3821	2895	10395	2895	2895				L8SK3	PMT	05/20/2022
F15	SO	05/20/2022	-5814	-5814	-5814	22503	22503			0	0	0	0	F5507	16689	16689	16689	16689				HMSRD	PMT	05/20/2022
F15	SO	05/20/2022	-8638	-8638	-8638	57646	57646			0	0	0	0	F6946	49008	49008	49008	49008				LDP3	PMT	05/20/2022
F15	SO	05/21/2022	-21514	-21514	-21514	77376	77376			0	0	0	0	F6931	55862	55862	55862	55862				L8SK3	PMT	05/20/2022
F9	SO	05/21/2022	-10430	-10430	-10430	86516	86516			0	0	0	0	F6929	76086	76086	76086	76086		50000	6/15/2022	L5SK3	PMT	05/20/2022
F4	SO	05/21/2022	-8255	-8255	-8255	93009	91009			0	0	0	0	GPH	82754	84754	82754	82754		23238	7/12/2022	LGP3	PMT	05/20/2022
F17	PMT	05/21/2022	-7773	-7773	-7773	104926	104926			0	0	0	0	F6947	97153	97153	97153	97153				L9OG3	PMT	05/20/2022
F4	PMT	05/21/2022	-16476	-16476	-16476	118808	118808			0	0	0	0	F6932	102332	102332	102332	102332		150000	6/15/2022	L10SK3	PMT	05/20/2022
F15	PM	05/21/2022	-7920	-7920	-7920	220348	194403			0	0	0	0	ASHH41	170866	202480	176535	173188				ASHH41CB	PM	08/25/2022
F5	PMT	05/22/2022	-14343.3838	-14343.3838	-14343.3838	431580	131580			0	0	0	0	LINER08	86670	386670	86670	86670		1152000	6/10/2022	L8SK3	PMT	05/20/2022
F1	PMT	05/23/2022	-10984.5492	-10984.5492	-10984.5492	431580	131580			0	0	0	0	LINER08	119609	419609	119609	119609		1152000	6/10/2022	L10SK3	PMT	05/20/2022
F1	PMT	05/24/2022	-5182.2591	-5182.2591	-5182.2591	431580	131580			0	0	0	0	LINER08	80130	380130	80130	80130		1152000	6/10/2022	L9OG3	PMT	05/20/2022
F20	PMT	05/20/2022	-6953.681	-6953.681	-6953.681	682171	482171			0	0	0	0	LINER09	469872	669872	469872	469872		384000	7/6/2022	L5SK3	PMT	05/20/2022
F31761	SO	05/23/2022	-33753	-1240		203989	197989			0	0	0			164236	202749	196749
F1	SOT	05/23/2022	-21514	-21514	-21514					-21514	-21514	-21514	-21514									L8SK3	SOT	05/23/2022

Results

Item	TranType	Date	PDQty	SOQty	SOSfQty	BB	BBSfty	D/O	D/Oadj	ALL-PD	BB-SO	ALL-SO	ALL-SOSF	Cast	AB-PD	AB-SO	AB-ALLSO	AB-SOSR	Desc	Onorder	Date	Item	TranType	Date
F1	PMT	5/24/2022	-5182.259	-5182.259	-5182.259	431580	131580			0	0	0	0	LINER08	80130	380130	80130	80130		1152000	#######	L9OG3	PMT	#######
F1	PMT	5/23/2022	-10984.55	-10984.55	-10984.55	431580	131580			0	0	0	0	LINER08	119609	419609	119609	119609		1152000	#######	L10SK3	PMT	#######
F1	SOT	5/23/2022	-21514	-21514	-21514					-21514	-21514	-21514	-21514									L8SK3	SOT	#######
F15	PM	5/21/2022	-7920	-7920	-7920	220348	194403			0	0	0	0	ASHH41	170866	202480	176535	173188				ASHH41CB	PM	#######
F15	SO	5/21/2022	-21514	-21514	-21514	77376	77376			0	0	0	0	F6931	55862	55862	55862	55862				L8SK3	PMT	#######
F15	SO	5/20/2022	-8638	-8638	-8638	57646	57646			0	0	0	0	F6946	49008	49008	49008	49008				LDP3	PMT	#######
F15	SO	5/20/2022	-5814	-5814	-5814	22503	22503			0	0	0	0	F5507	16689	16689	16689	16689				HMSRD	PMT	#######
F17	PM	5/22/2022	-8255	-8255	-8255	12117	12117			0	0	0	0	C1360	3862	3862	3862	3862				LGP3	PMT	#######
F17	PM	5/21/2022	-6608	-6608	-6608	5439	5439			-1169	-1169	-1169	-1169	F6909	-1169	-1169	-1169	-1169		10000	6/9/2022	L8RFIP	PMT	#######
F17	PMT	5/21/2022	-7773	-7773	-7773	104926	104926			0	0	0	0	F6947	97153	97153	97153	97153				L9OG3	PMT	#######
F18	PM	5/20/2022	-7326.27	-7326.27	-7326.27	34	34			-7292	-7292	-7292	-7292	HEATXC	-7292	-7292	-7292	-7292		19821	#######	H3SK	PMT	#######
F2	PMT	5/24/2022	-7170.616	-7170.616	-7170.616	18668	11168			0	0	0	0	C3821	2895	10395	2895	2895				L8SK3	PMT	#######
F20	PMT	5/20/2022	-6953.681	-6953.681	-6953.681	682171	482171			0	0	0	0	LINER09	469872	669872	469872	469872		384000	7/6/2022	L5SK3	PMT	#######
F25	PMT	5/23/2022	-5491.451	-5491.451	-5491.451	14478	8478			0	0	0	0	C1021	2987	8987	2987	2987				L10SK3	PMT	#######
F31761	SO	5/23/2022	-33753	-1240		203989	197989			0	0	0			164236	202749	196749
F4	PMT	5/21/2022	-16476	-16476	-16476	118808	118808			0	0	0	0	F6932	102332	102332	102332	102332		150000	#######	L10SK3	PMT	#######
F4	SO	5/21/2022	-8255	-8255	-8255	93009	91009			0	0	0	0	GPH	82754	84754	82754	82754		23238	#######	LGP3	PMT	#######
F5	PMT	5/22/2022	-14343.38	-14343.38	-14343.38	431580	131580			0	0	0	0	LINER08	86670	386670	86670	86670		1152000	#######	L8SK3	PMT	#######
F7	PMT	5/20/2022	-10523.34	-10523.34	-10523.34	34	34			-10523	-10523	-10523	-10523	HEATXC	-21863	-21863	-21863	-21863		19821	#######	HMSRD	PMT	#######
F9	SO	5/21/2022	-10430	-10430	-10430	86516	86516			0	0	0	0	F6929	76086	76086	76086	76086		50000	#######	L5SK3	PMT	#######

Natas · May 24, 2022

BSALV said:
excel365 (and 2021?) has it own sort-function for 2D-arrays ascending, descending but with only 1 key (!)

VBA Code:

Sub SortArrays() arr1 = ActiveSheet.Range("A1").CurrentRegion arr2 = Application.Sort(arr1, 3, -1) Range("E1").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2 End Sub

Oooh, thanks. I did not know this. I'll have to play around with it tomorrow!

johnnyL · May 24, 2022

johnnyL said:
Welcome to the mrexcel @Natas.

Thank you for the offering.

I don't see where you display the results from the sorted array though.

That was my mistake, I should have been clearer.

I don't see the line of code that will display the sorted array to a sheet.

Natas · May 25, 2022

Oh, I usually write it after the call statement to Sub QuickSort2D.
It would be setting the range to the worksheet I was going to copy into, resize to array, and equals.

Like this:

VBA Code:

Dim rnga as range
Set rnga = OutPutSheet.Cells(1, 1)
rnga.Resize(UBound(Arr, 1), UBound(Arr, 2)).Value = Arr

Natas · May 25, 2022

Natas said:
Oooh, thanks. I did not know this. I'll have to play around with it tomorrow!

BSALV said:
excel365 (and 2021?) has it own sort-function for 2D-arrays ascending, descending but with only 1 key (!)

VBA Code:

Sub SortArrays() arr1 = ActiveSheet.Range("A1").CurrentRegion arr2 = Application.Sort(arr1, 3, -1) Range("E1").Resize(UBound(arr2), UBound(arr2, 2)).Value = arr2 End Sub

Nice. Doing a speed comparison side by side running the sort 10 times of an array 35000x22, the application.sort method is slightly faster at 9 seconds and my program at 10 seconds. Running the sort three times, one against each column I want to sort as follows, achieves the same results. However, needs to start from reverse order of sorting the columns of priority. Excels sort still suffers from the same problem that it will rank the number 500 lower down than 1000 in the column. EDIT(This is probably due to me having the column forced into text as it contains a mixture of serial numbers and text, so technically it is doing as it should)
I edited your code slightly to not include the header in the sorts.
Thanks so much, this was a jewel to find.

Code:

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

BSALV · May 25, 2022

only for 2021-365
if you sort 3 times, that doesn't result in a combined sort.
So i tried this one, an array 100.000 * 5 sorting every column alternative descending and ascending (= 3D + 2A) in 3.5 seconds
arraySort
I hope i didn't make an error somewhere ... and i didn't check the 500-1000 bug

VBA Code:

Sub sorting()
     Dim aux
  
     ActiveSheet.Cells.ClearContents
   
   t = Timer
     Set dict = CreateObject("scripting.dictionary") 'dictionary for indexnumber per key and value


     arr = WorksheetFunction.RandArray(100000, 5, 1, 10, 1) '35000*5 cells random value 1-10
     Range("A1").Resize(UBound(arr), UBound(arr, 2)).Value = arr 'write to sheet

     For i = 1 To 5 'sort 5 times
          aux = Application.Sort(arr, i, IIf(i Mod 2, -1, 1)) 'copy original array 5 times each time another column, from column 1 to column 5, alternative Descending & ascending
          ptr = 0 'reset index
          For r = 1 To UBound(aux) 'loop through all the values in the sorted column
               b = (r = 1): If Not b Then b = (aux(r, i) <> aux(r - 1, i)) 'new values, so increment of the pointer
               If b Then
                    ptr = ptr + 1 'increment pointer
                    dict("Key" & i & "|" & aux(r, i)) = "'" & Format(ptr, "00000") 'add to dictionary
               End If
          Next
     Next

     aux = arr '
     ReDim Preserve aux(1 To UBound(arr), 1 To UBound(arr, 2) + 1) 'add a new column to the array

     For i = 1 To UBound(aux)
          For j = 1 To UBound(aux, 2) - 1
               aux(i, UBound(aux, 2)) = aux(i, UBound(aux, 2)) & "|" & dict("Key" & j & "|" & aux(i, j)) 'new column = combined sortkey of the previous 5
          Next
     Next

     aux2 = Application.Sort(aux, 6, 1) 'sort on that combined key
     Range("H1").Resize(UBound(aux2), UBound(aux2, 2)).Value = aux2 'write sorted array to sheet

     'With Range("R1").Resize(dict.Count)
     '     .Value = Application.Transpose(dict.keys)
     '     .Offset(, 1).Value = Application.Transpose(dict.items)
     'End With
     
     MsgBox Timer - t
End Sub

John_w · May 25, 2022

Natas said:
The only thing I've noticed since I've created it, it doesn't sort numbers correctly. If the Item's say were just a serial numbers, it would sort a 300 lower 77. Any tips?

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

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

Natas

New Member

Excel Facts

johnnyL

Well-known Member

BSALV

Banned user

Natas

New Member

Natas

New Member

johnnyL

Well-known Member

Natas

New Member

Natas

New Member

BSALV

Banned user

John_w

MrExcel MVP

Similar threads

Forum statistics

Share this page

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

New Member

Excel Facts

Well-known Member

Banned user

New Member

New Member

Well-known Member

New Member

New Member

Banned user

MrExcel MVP

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock