Consulting

Results 1 to 14 of 14

Thread: Sort Multidimensional Array

  1. #1

    Sort Multidimensional Array

    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.

  2. #2
    VBAX Guru Kenneth Hobs's Avatar
    Joined
    Nov 2005
    Location
    Tecumseh, OK
    Posts
    4,954
    Location
    An easy method is to join the "columns" by a special character. After the standard bubble sort, split each element to rebuild the array.

  3. #3
    VBAX Tutor Mavyak's Avatar
    Joined
    Jul 2008
    Posts
    204
    Location
    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

  4. #4
    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.
    Last edited by Aussiebear; 03-31-2023 at 06:26 AM. Reason: Adjusted the code tags

  5. #5
    Distinguished Lord of VBAX VBAX Grand Master Bob Phillips's Avatar
    Joined
    Apr 2005
    Posts
    25,446
    Location
    ____________________________________________
    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

  6. #6
    VBAX Tutor Mavyak's Avatar
    Joined
    Jul 2008
    Posts
    204
    Location
    Quote Originally Posted by realitybend
    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.

  7. #7
    Mac Moderator VBAX Guru mikerickson's Avatar
    Joined
    May 2007
    Location
    Davis CA
    Posts
    2,776
    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

  8. #8
    Thanks! Problem solved.

  9. #9
    VBAX Newbie
    Joined
    Nov 2016
    Posts
    3
    Location
    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!

  10. #10
    VBAX Sage
    Joined
    Apr 2007
    Location
    United States
    Posts
    8,785
    Location
    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

  11. #11
    Mac Moderator VBAX Guru mikerickson's Avatar
    Joined
    May 2007
    Location
    Davis CA
    Posts
    2,776
    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

  12. #12
    Mac Moderator VBAX Guru mikerickson's Avatar
    Joined
    May 2007
    Location
    Davis CA
    Posts
    2,776
    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

  13. #13
    VBAX Newbie
    Joined
    Nov 2016
    Posts
    3
    Location
    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.

  14. #14
    VBAX Newbie
    Joined
    Nov 2016
    Posts
    3
    Location
    It worked!. Thanks so much!

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •