How do you sort a multidimensional "MyArray(x, 2)" by the first column (I guess you'd call it a column)? All values are numerical.
How do you sort a multidimensional "MyArray(x, 2)" by the first column (I guess you'd call it a column)? All values are numerical.
An easy method is to join the "columns" by a special character. After the standard bubble sort, split each element to rebuild the array.
You can also make Excel do the sort for you:
Sub TryIt() Dim MyArray As Variant, x As Integer, y As Integer MyArray = Selection '<--Comment out this line and replace "MyArray" in the next line with your own two-dimensional 'array or you could select two columns of data and run the code as is. SortArray MyArray For x = 1 To UBound(MyArray, 1) For y = 1 To UBound(MyArray, 2) Debug.Print MyArray(x, y) & " "; Next y Debug.Print Next x End Sub Sub SortArray(ByRef MyArray As Variant) 'Dim MyArray As Variant Dim w As Worksheet Dim r As Range Set w = ThisWorkbook.Worksheets.Add() 'MyArray = Selection w.Range("A1", w.Range("A1").Offset(UBound(MyArray, 1) - 1, UBound(MyArray, 2) - 1)) = MyArray Set r = w.Range("A1", w.Range("A1").Offset(UBound(MyArray, 1) - 1, UBound(MyArray, 2) - 1)) r.Sort Key1:=r.Cells(1, 1) MyArray = r Set r = Nothing Application.DisplayAlerts = False w.Delete Application.DisplayAlerts = True Set w = Nothing End Sub
Last edited by Aussiebear; 03-31-2023 at 06:26 AM. Reason: Adjusted the code tags
I get a type mismatch here:I've changed it to an array, like you said, which contains exactly the same data as what I selected when it worked.w.Range("A1", w.Range("A1").OffSet(UBound(Myarray, 1) - 1, UBound(Myarray, 2) - 1)) = Myarray
What's wrong?
Thanks.
Edit: I changed "MyArray" to "Myarray" on purpose.
Last edited by Aussiebear; 03-31-2023 at 06:26 AM. Reason: Adjusted the code tags
from the archives http://www.vbaexpress.com/forum/showthread.php?t=12619
____________________________________________
Nihil simul inventum est et perfectum
Abusus non tollit usum
Last night I dreamed of a small consolation enjoyed only by the blind: Nobody knows the trouble I've not seen!
James Thurber
The SortArray function is expecting a variant. I suspect you explicitly declared your array variable as a String. You could Dim a variant variable and store your array in it temporarily to pass it to the SortArray function and then return the contents to your array. Or, you could follow xld's link and bubble-sort it. I only wrote the code above because I hadn't encountered the situation before. I see a puzzle like that sometimes and want to find a way to make it work. The bubble-sort will be less costly overhead-wise since it doesn't create/destroy any objects.Originally Posted by realitybend
This UDF should do the trick
QSortedArray() takes either a range or an array as its first argument, the second and third arguments (optional) are the columns to sort on. The Decenting determines if the sort is ascending (default) descending.
Option Explicit Public imageArray As Variant Public keyCol As Long, keyCol2 Function QSortedArray(ByVal inputRange As Variant, Optional keyColumn As Long, Optional keyColumn2 As Long, Optional Descending As Boolean) As Variant Dim RowArray As Variant Dim outRRay As Variant Dim i As Long, j As Long, size As Long If keyColumn = 0 Then keyColumn = 1 Rem Input array vs range handeling On Error GoTo HaltFunction Select Case TypeName(inputRange) Case Is = "Range" If inputRange.Columns.Count < keyColumn Then QSortedArray = CVErr(xlErrRef): Exit Function Else Set inputRange = Application.Intersect(inputRange, inputRange.Parent.UsedRange) If inputRange Is Nothing Then QSortedArray = Array(vbNullString): Exit Function Else imageArray = inputRange.Value End If End If Case Is = "Variant()", "String()", "Double()", "Long()" If UBound(inputRange, 2) < keyColumn Then QSortedArray = Array(CVErr(xlErrRef)): Exit Function Else imageArray = inputRange End If Case Else QSortedArray = CVErr(xlErrNA): Exit Function End Select On Error GoTo 0 Rem pass arguments To Public variables If keyColumn2 = 0 Then keyColumn2 = keyColumn If UBound(imageArray, 2) < keyColumn Then QSortedArray = CVErr(xlErrRef): Exit Function If UBound(imageArray, 2) < keyColumn2 Then QSortedArray = CVErr(xlErrRef): Exit Function keyCol = keyColumn keyCol2 = keyColumn2 Rem create array of row numbers {1,2,3,...,Rows.Count} size = UBound(imageArray, 1) ReDim RowArray(1 To size) For i = 1 To size RowArray(i) = i Next i Rem sort row numbers Call sortQuickly(RowArray, Descending) Rem read imageArray With row order per the sorted RowArray ReDim outRRay(1 To size, 1 To UBound(imageArray, 2)) For i = 1 To size For j = 1 To UBound(outRRay, 2) outRRay(i, j) = imageArray(RowArray(i), j) Next j Next i QSortedArray = outRRay Erase imageArray HaltFunction: On Error GoTo 0 End Function Sub sortQuickly(ByRef inRRay As Variant, Optional ByVal Descending As Boolean, Optional ByVal low As Long, Optional ByVal high As Long) Dim pivot As Variant Dim i As Long, pointer As Long If low = 0 Then low = LBound(inRRay) If high = 0 Then high = UBound(inRRay) pointer = low Call Swap(inRRay, (low + high) / 2, high) pivot = inRRay(high) For i = low To high - 1 If LT(inRRay(i), pivot) Xor Descending Then Call Swap(inRRay, i, pointer) pointer = pointer + 1 End If Next i Call Swap(inRRay, pointer, high) If low < pointer - 1 Then Call sortQuickly(inRRay, Descending, low, pointer - 1) End If If pointer + 1 <= high Then Call sortQuickly(inRRay, Descending, pointer + 1, high) End If End Sub Function LT(aRow As Variant, bRow As Variant, Optional Descending As Boolean) As Boolean On Error GoTo HaltFtn LT = Descending If imageArray(aRow, keyCol) = imageArray(bRow, keyCol) Then LT = imageArray(aRow, keyCol2) < imageArray(bRow, keyCol2) Else LT = (imageArray(aRow, keyCol) < imageArray(bRow, keyCol)) End If HaltFtn: On Error GoTo 0 End Function Sub Swap(ByRef inRRay, a As Long, b As Long) Dim temp As Variant temp = inRRay(a) inRRay(a) = inRRay(b) inRRay(b) = temp End Sub
Last edited by Aussiebear; 03-31-2023 at 06:28 AM. Reason: Adjusted the code tags
Thanks! Problem solved.
Hi. This is great. I used it and modified so it works with 3 column criteria (one after the other). The problem I have is that with arrays bigger than 500,000 rows it gives me an Out of Stack Space error (Error 28). I've read about it and I understand is related to the RAM use of the heavily recursive method (I only have 4Gb RAM in a 64 Excel 2016). The point is that I need to make this work for roughly 5 million row arrays (5 columns) and sorted by 3 columns criteria. I'm lost in ideas how to make this algorithm a bit slower but less reliant on RAM or if there is any way the variables declarations can be modified so it erases the content the arrays that are not going to be used anymore? Thanks so much!
Welcome
This is a very old post, so it'd be better and you'll get more responses if you start your own with a 'catchy' title
Quick Sort is recursive, and so it can run out of stack space, esp. with a lot of data
Chip Pearson has a module that does the quick sort in place, that MIGHT be better. I've never used it
http://www.cpearson.com/excel/SortingArrays.aspx
http://www.cpearson.com/Zips/modQSortInPlace.zip
Public Function QSortInPlace( _ ByRef InputArray As Variant, _ Optional ByVal LB As Long = -1&, _ Optional ByVal UB As Long = -1&, _ Optional ByVal Descending As Boolean = False, _ Optional ByVal CompareMode As VbCompareMethod = vbTextCompare, _ Optional ByVal NoAlerts As Boolean = False) As Boolean
If the data is on a WS, I'd just use the WS sort, no size limits and it's fast.
If the data is only in a VBA array, I'd copy it to a temp WS, sort it, put it back into the array, and delete the temp WS
---------------------------------------------------------------------------------------------------------------------
Paul
Remember: Tell us WHAT you want to do, not HOW you think you want to do it
1. Use [CODE] ....[/CODE ] Tags for readability
[CODE]PasteYourCodeHere[/CODE ] -- (or paste your code, select it, click [#] button)
2. Upload an example
Go Advanced / Attachments - Manage Attachments / Add Files / Select Files / Select the file(s) / Upload Files / Done
3. Mark the thread as [Solved] when you have an answer
Thread Tools (on the top right corner, above the first message)
4. Read the Forum FAQ, especially the part about cross-posting in other forums
http://www.vbaexpress.com/forum/faq...._new_faq_item3
Here is a version that doesn't use recursion.
You will have to adjust the getting of the UnsortedArray in test, the output of the SortedArray and (in the function LT), the columns of interest
Dim UnSortedArray As Variant Sub test() Dim i As Long, j As Long, temp As Variant Dim Pivot As Long, PivotPlace As Long Dim Low As Long, High As Long Dim Stack() As Long, StackPointer As Long Dim rowArray() As Long, sortedArray As Variant Rem get unsorted array, adjust UnSortedArray = Range("A1:C6").Value ReDim Stack(1 To 2, 0 To 0) ReDim rowArray(LBound(UnSortedArray, 1) To UBound(UnSortedArray, 1)) For i = LBound(UnSortedArray, 1) To UBound(UnSortedArray, 1) rowArray(i) = i Next i Low = LBound(rowArray): High = UBound(rowArray) GoSub Push Do Until StackPointer <= 0 GoSub Pop i = (Low + High) / 2 temp = rowArray(i) rowArray(i) = rowArray(High) rowArray(High) = temp Pivot = rowArray(High) PivotPlace = Low For i = Low To High - 1 If LT(rowArray(i), Pivot) Then temp = rowArray(i) rowArray(i) = rowArray(PivotPlace) rowArray(PivotPlace) = temp PivotPlace = PivotPlace + 1 End If Next i rowArray(High) = rowArray(PivotPlace) rowArray(PivotPlace) = Pivot i = Low: j = High If Low < PivotPlace Then High = PivotPlace - 1 GoSub Push End If If PivotPlace < j Then High = j Low = PivotPlace + 1 GoSub Push End If Loop sortedArray = UnSortedArray For i = LBound(UnSortedArray, 1) To UBound(UnSortedArray, 1) For j = LBound(UnSortedArray, 2) To UBound(UnSortedArray, 2) sortedArray(i, j) = UnSortedArray(rowArray(i), j) Next j Next i Rem adjust output Range("I1").Resize(UBound(sortedArray, 1), UBound(sortedArray, 2)).Value = sortedArray Exit Sub Push: StackPointer = StackPointer + 1 If UBound(Stack, 2) < StackPointer Then ReDim Preserve Stack(1 To 2, 0 To 2 * StackPointer) Stack(1, StackPointer) = Low Stack(2, StackPointer) = High Return Pop: Low = Stack(1, StackPointer) High = Stack(2, StackPointer) StackPointer = StackPointer - 1 Return End Sub Function LT(a As Long, b As Long) As Boolean Dim col1 As Long, col2 As Long, col3 As Long col1 = 1 col2 = 2 col3 = 3 If (UnSortedArray(a, col1) < UnSortedArray(b, col1)) Or (UnSortedArray(a, col1) = vbNullString) Then LT = True ElseIf (UnSortedArray(b, col1) < UnSortedArray(a, col1)) Or (UnSortedArray(b, col1) = vbNullString) Then LT = False Else If UnSortedArray(a, col2) < UnSortedArray(b, col2) Then LT = True ElseIf UnSortedArray(b, col2) < UnSortedArray(a, col2) Then LT = False Else LT = UnSortedArray(a, col3) < UnSortedArray(a, col3) End If End If End Function
This is a cleaned up version of the above, with a Descending variable that can be set as desired.
Dim UnSortedArray As Variant Sub test() Dim i As Long, j As Long, temp As Variant Dim Pivot As Long, PivotPlace As Long Dim rowLow As Long, rowHigh As Long Dim colLow As Long, colHigh As Long Dim Descending As Boolean Dim Low As Long, High As Long Dim Stack() As Long, StackPointer As Long Dim rowArray() As Long, sortedArray As Variant Dim Descending As Boolean Descending = False: Rem set As desired ReDim Stack(1 To 2, 0 To 0) Rem get unsorted array, adjust With Sheet1.Range("A:A") UnSortedArray = Range(.Cells(Rows.Count, 1).End(xlUp), .Cells(1, 4)).Value End With rowLow = LBound(UnSortedArray, 1) rowHigh = UBound(UnSortedArray, 1) colLow = LBound(UnSortedArray, 2) colHigh = UBound(UnSortedArray, 2) Rem make array of row numbers ReDim rowArray(rowLow To rowHigh) For i = rowLow To rowHigh rowArray(i) = i Next i Rem sort array of row numbers ordered by unsortedArray values in LT function Low = rowLow: High = rowHigh GoSub Push Do Until StackPointer <= 0 GoSub Pop Rem pivot choosing i = (Low + High) / 2 temp = rowArray(i) rowArray(i) = rowArray(High) rowArray(High) = temp Pivot = rowArray(High) PivotPlace = Low For i = Low To High - 1 If LT(rowArray(i), Pivot, Descending) Then temp = rowArray(i) rowArray(i) = rowArray(PivotPlace) rowArray(PivotPlace) = temp PivotPlace = PivotPlace + 1 End If Next i rowArray(High) = rowArray(PivotPlace) rowArray(PivotPlace) = Pivot i = Low: j = High If Low < PivotPlace Then High = PivotPlace - 1 GoSub Push End If If PivotPlace < j Then High = j Low = PivotPlace + 1 GoSub Push End If Loop Rem convert sorted array of row numbers into sortedArray sortedArray = UnSortedArray For i = rowLow To rowHigh For j = colLow To colHigh sortedArray(i, j) = UnSortedArray(rowArray(i), j) Next j Next i Rem adjust output Range("I1").Resize(rowHigh, colHigh).Value = sortedArray Exit Sub Push: StackPointer = StackPointer + 1 If UBound(Stack, 2) < StackPointer Then ReDim Preserve Stack(1 To 2, 0 To 2 * StackPointer) Stack(1, StackPointer) = Low Stack(2, StackPointer) = High Return Pop: Low = Stack(1, StackPointer) High = Stack(2, StackPointer) StackPointer = StackPointer - 1 Return End Sub Function LT(a As Long, b As Long, Optional Descending As Boolean = False) As Boolean Dim col1 As Long, col2 As Long, col3 As Long col1 = 1 col2 = 2 col3 = 3 Rem nullString is GT everything If UnSortedArray(a, col1) = vbNullString Then LT = False ElseIf UnSortedArray(b, col1) = vbNullString Then LT = True ElseIf (UnSortedArray(a, col1) < UnSortedArray(b, col1)) Then LT = True Xor Descending ElseIf (UnSortedArray(b, col1) < UnSortedArray(a, col1)) Then LT = False Xor Descending Else If UnSortedArray(a, col2) < UnSortedArray(b, col2) Then LT = True Xor Descending ElseIf UnSortedArray(b, col2) < UnSortedArray(a, col2) Then LT = False Xor Descending Else LT = (UnSortedArray(a, col3) < UnSortedArray(b, col3)) Xor Descending End If End If End Function
Excellent. I'll translate my (5,000,000 x 5) array to the UnSortedArray and see how it goes. I'll let you know. Thanks mikerickson.
It worked!. Thanks so much!