Sort Multidimensional Array

[realitybend]

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.

[Kenneth Hobs]

An easy method is to join the "columns" by a special character. After the standard bubble sort, split each element to rebuild the array.

[Mavyak]

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

[realitybend]

I get a type mismatch here:

w.Range("A1", w.Range("A1").OffSet(UBound(Myarray, 1) - 1, UBound(Myarray, 2) - 1)) = Myarray

I've changed it to an array, like you said, which contains exactly the same data as what I selected when it worked.

What's wrong?

Thanks.

Edit: I changed "MyArray" to "Myarray" on purpose.

[Bob Phillips]

from the archives http://www.vbaexpress.com/forum/showthread.php?t=12619

[Mavyak]

I've changed it to an array, like you said, which contains exactly the same data as what I selected when it worked.

What's wrong?

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.

[mikerickson]

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

[realitybend]

Thanks! Problem solved.

[eamonter]

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!

[Paul_Hossler]

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

[mikerickson]

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

[mikerickson]

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

[eamonter]

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.

[eamonter]

It worked!. Thanks so much!