Results 1 to 3 of 3

Thread: [RESOLVED] VS2010 MultiDimesional Array Sort based on several criteria

  1. #1

    Thread Starter
    Junior Member
    Join Date
    Jan 2014
    Location
    Athens, Greece
    Posts
    30

    Resolved [RESOLVED] VS2010 MultiDimesional Array Sort based on several criteria

    Hi to all

    I am having trouble trying to sort a 2-dimensional string array [10,5] by column order 1,2 and 3 (similar to Excel, which I want to avoid) or any other combination. I managed to get the result I need but in a very crude way. Could someone point a more efficient way please ?
    Thanks

    Code:
    Public Class Form1
    
        ' try to sort a multi-dimensional array based on one or more criteria.
        ' here will use 3 criteria, DATE, BUS ID and DEP TIME.
    
        Dim maxFields = 5
    
        Dim arr(10, maxFields) As String
        Dim sortedArr(10, maxFields) As String   ' to accept original arr()
        Dim tempo(10, maxFields) As String       ' to use for temporary swaps
    
        Dim maxRecs As Integer
        Dim s As String
    
        Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
            SortingItNow()
        End Sub
    
        Private Sub Form1_Load(sender As Object, e As EventArgs) Handles Me.Load
    
            ' fields
            ' 1 = date
            ' 2 = bus
            ' 3 = dep time(s)
            ' 4 = rec nbr
            ' 5 = driver code
    
            arr(1, 1) = "05-Apr-2015" : arr(1, 2) = "bus-1" : arr(1, 3) = "10:45" : arr(1, 4) = "1" : arr(1, 5) = "TSA"
            arr(2, 1) = "05-Apr-2015" : arr(2, 2) = "bus-2" : arr(2, 3) = "10:30" : arr(2, 4) = "2" : arr(2, 5) = "ZIF"
            arr(3, 1) = "05-Apr-2015" : arr(3, 2) = "bus-1" : arr(3, 3) = "08:00" : arr(3, 4) = "3" : arr(3, 5) = "TSA"
            arr(4, 1) = "02-Apr-2015" : arr(4, 2) = "bus-1" : arr(4, 3) = "08:20" : arr(4, 4) = "4" : arr(4, 5) = "LIN"
    
            maxRecs = 4
    
            RichTextBox1.Text = "start"
            RichTextBox1.Text = RichTextBox1.Text & Chr(10)
            RichTextBox1.Text = RichTextBox1.Text & arr(1, 1) & " " & arr(1, 2) & " " & arr(1, 3) & " " & arr(1, 4) & " " & arr(1, 5) & " " & Chr(10)
            RichTextBox1.Text = RichTextBox1.Text & arr(2, 1) & " " & arr(2, 2) & " " & arr(2, 3) & " " & arr(2, 4) & " " & arr(2, 5) & " " & Chr(10)
            RichTextBox1.Text = RichTextBox1.Text & arr(3, 1) & " " & arr(3, 2) & " " & arr(3, 3) & " " & arr(3, 4) & " " & arr(3, 5) & " " & Chr(10)
            RichTextBox1.Text = RichTextBox1.Text & arr(4, 1) & " " & arr(4, 2) & " " & arr(4, 3) & " " & arr(4, 4) & " " & arr(4, 5) & " " & Chr(10)
            RichTextBox1.Text = RichTextBox1.Text & "end"
    
    
        End Sub
    
        Private Sub SortingItNow()
    
            Dim sortCond, StartRec, EndRec As Integer
            Dim totItems, sortField As Integer
            Dim s
            s = ""
            totItems = maxRecs
    
            For n = 1 To maxRecs
                For j = 1 To maxFields
                    sortedArr(n, j) = arr(n, j)
                    tempo(n, j) = ""
                Next
            Next
    
            '================================
            ' sort for first condition
            '================================
    
            sortCond = 1   ' date - ORIGINAL SORT
            StartRec = 1
            EndRec = maxRecs
            SortRecs(sortCond, StartRec, EndRec)
            '
            DisplayA()
    
            '----------------------------------------------------------------------------
    
            Dim remaining, oldLine, nextLine, tot As Short
            remaining = maxRecs
            nextLine = 0
            oldLine = 0
            tot = 0
    
            sortField = 1   ' date
            For n = 1 To maxRecs
                tot = tot + 1
                For j = 1 To maxFields : tempo(n, j) = sortedArr(n, j) : Next j
                ' if DATE differs
                If n > 1 And sortedArr(n, sortField) <> sortedArr(n - 1, sortField) Then
                    remaining = remaining - 1       ' remaining items to sort ALWAYS < maxRecs
                    nextLine = n                    ' remember current position - VERY VOLATILE ?!
                    tot = tot - 1                   ' total elements for sorting till now !
                    oldLine = n
                    Exit For
                End If
            Next
    
            ' tot + remaining MUST BE EQUAL TO =  maxRecs
    
            If tot > 1 Then
                'sort elements till now
                sortCond = 2   ' bus id
                StartRec = 1
                EndRec = tot
                SortRecs(sortCond, StartRec, EndRec)
            Else
                ' seems none or only 1 item found so keep it...  ???!!!
    
            End If
    
            For n = nextLine To maxRecs
                tot = tot + 1                       ' continue count from last value...
                For j = 1 To maxFields : tempo(n, j) = sortedArr(n, j) : Next j
                ' if DATE differs
                If n > nextLine And sortedArr(n, sortField) <> sortedArr(n - 1, sortField) Then
                    remaining = remaining - 1       ' remaining items to sort ALWAYS < maxRecs
                    nextLine = n                    ' remember current position - VERY VOLATILE ?!
                    tot = tot - 1                   ' total elements for sorting till now !
                    Exit For
                Else
    
                End If
            Next
    
            '================================
            ' sort for second condition
            '================================
    
            If tot > 1 Then
                'sort elements till now
                sortCond = 2   ' bus id
                StartRec = nextLine
                EndRec = maxRecs
                SortRecs(sortCond, StartRec, EndRec)
            Else
                ' seems none or only 1 item found so keep it
            End If
            '
            DisplayB()
    
            '================================
            ' now HOLD TWO CONDITIONS and sort for third !!
            '================================
    
            Dim firstFound, lastFound
            firstFound = 0
            lastFound = 0
    
            ' here record 1 and 4 are preserved, 2 and 3 sorted per dep time.
            For n = nextLine To maxRecs
                If n > nextLine And sortedArr(n, 1) = sortedArr(n - 1, 1) And sortedArr(n, 2) = sortedArr(n - 1, 2) Then
                    ' Mark first / last record lines for sorting
                    If firstFound = 0 Then firstFound = n - 1
                    lastFound = n
                End If
            Next
    
            sortcond = 3
            startrec = firstFound
            endrec = lastFound
            SortRecs(sortCond, startRec, EndRec)
            '
            DisplayC()
    
        End Sub
    
        Sub SortRecs(sortCond, StartRec, EndRec)
            ' sorting routine
            Dim sortField As Short
            sortField = sortCond
            For i = startRec To EndRec
                For j = startRec To (EndRec - 1)
                    If sortedArr(j, sortField) > sortedArr((j + 1), sortField) Then
                        For w = 1 To maxFields
                            tempo(j, w) = sortedArr(j, w)
                        Next
                        For w = 1 To maxFields
                            sortedArr(j, w) = sortedArr((j + 1), w)
                        Next
                        For w = 1 To maxFields
                            sortedArr((j + 1), w) = tempo(j, w)
                        Next
                    End If
                Next j
            Next i
        End Sub
    
        Sub DisplayA()
            s = ""
            RichTextBox2.Text = "start"
            For n = 1 To maxRecs
                For j = 1 To maxFields
                    s = s & sortedArr(n, j) & " "
                Next
                RichTextBox2.Text = RichTextBox2.Text & Chr(10) & s
                s = ""
            Next
            RichTextBox2.Text = RichTextBox2.Text & Chr(10) & "end"
        End Sub
    
        Sub DisplayB()
            s = ""
            RichTextBox3.Text = "start"
            For n = 1 To maxRecs
                For j = 1 To maxFields
                    s = s & sortedArr(n, j) & " "
                Next
                RichTextBox3.Text = RichTextBox3.Text & Chr(10) & s
                s = ""
            Next
            RichTextBox3.Text = RichTextBox3.Text & Chr(10) & "end"
        End Sub
    
        Sub DisplayC()
            s = ""
            RichTextBox4.Text = "start"
            For n = 1 To maxRecs
                For j = 1 To maxFields
                    s = s & sortedArr(n, j) & " "
                Next
                RichTextBox4.Text = RichTextBox4.Text & Chr(10) & s
                s = ""
            Next
            RichTextBox4.Text = RichTextBox4.Text & Chr(10) & "end"
        End Sub
    
    End Class
    Name:  sorting.jpg
Views: 126
Size:  18.8 KB
    Last edited by vangos; Apr 14th, 2015 at 06:09 PM. Reason: image added

  2. #2
    eXtreme Programmer .paul.'s Avatar
    Join Date
    May 2007
    Location
    Chelmsford UK
    Posts
    23,421

    Re: VS2010 MultiDimesional Array Sort based on several criteria

    try this:

    Code:
    Public Class Form1
    
        Dim maxFields As Integer = 5
        Dim arr(10, maxFields) As String
        Dim sortedArr(,) As String
    
        Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
            '!!!remember arrays are zero based
            arr(0, 1) = "02-Apr-2016" : arr(0, 2) = "bus-4" : arr(0, 3) = "00:20" : arr(0, 4) = "2" : arr(0, 5) = "LIN"
            arr(1, 1) = "05-Apr-2015" : arr(1, 2) = "bus-1" : arr(1, 3) = "10:45" : arr(1, 4) = "4" : arr(1, 5) = "TSA"
            arr(2, 1) = "05-Apr-2015" : arr(2, 2) = "bus-2" : arr(2, 3) = "10:30" : arr(2, 4) = "3" : arr(2, 5) = "ZIF"
            arr(3, 1) = "05-Apr-2015" : arr(3, 2) = "bus-1" : arr(3, 3) = "08:00" : arr(3, 4) = "2" : arr(3, 5) = "TSA"
            arr(4, 1) = "02-Apr-2015" : arr(4, 2) = "bus-1" : arr(4, 3) = "08:20" : arr(4, 4) = "1" : arr(4, 5) = "LIN"
            arr(5, 1) = "02-Apr-2015" : arr(5, 2) = "bus-3" : arr(5, 3) = "10:45" : arr(5, 4) = "1" : arr(5, 5) = "TSA"
            arr(6, 1) = "02-Apr-2015" : arr(6, 2) = "bus-6" : arr(6, 3) = "10:30" : arr(6, 4) = "2" : arr(6, 5) = "ZIF"
            arr(7, 1) = "12-Apr-2015" : arr(7, 2) = "bus-1" : arr(7, 3) = "08:00" : arr(7, 4) = "3" : arr(7, 5) = "TSA"
            arr(8, 1) = "02-Apr-2016" : arr(8, 2) = "bus-1" : arr(8, 3) = "08:20" : arr(8, 4) = "4" : arr(8, 5) = "LIN"
            arr(9, 1) = "02-Apr-2015" : arr(9, 2) = "bus-1" : arr(9, 3) = "08:20" : arr(9, 4) = "3" : arr(9, 5) = "LIN"
            arr(10, 1) = "02-Apr-2015" : arr(10, 2) = "bus-4" : arr(10, 3) = "08:20" : arr(10, 4) = "2" : arr(10, 5) = "LIN"
    
            sortDynamically(New Integer() {1}, RichTextBox1)
            sortDynamically(New Integer() {1, 2}, RichTextBox2)
            sortDynamically(New Integer() {1, 2, 3}, RichTextBox3)
    
        End Sub
    
        Private Sub sortDynamically(ByVal sortBy() As Integer, ByVal outputTo As RichTextBox)
            sortedArr = DirectCast(arr.Clone, String(,))
    
            For outer As Integer = 0 To sortedArr.GetUpperBound(0)
                For inner As Integer = outer To 1 Step -1
                    For x As Integer = 0 To sortBy.GetUpperBound(0)
                        Dim compareValue As Integer = 0
                        Select Case sortBy(x)
                            Case 1 'date
                                compareValue = CDate(sortedArr(inner, sortBy(x))).CompareTo(CDate(sortedArr(inner - 1, sortBy(x))))
                            Case 2 'integer
                                compareValue = CInt(sortedArr(inner, sortBy(x)).Replace("bus-", "")).CompareTo(CInt(sortedArr(inner - 1, sortBy(x)).Replace("bus-", "")))
                            Case 3 'timespan
                                compareValue = TimeSpan.Parse(sortedArr(inner, sortBy(x))).CompareTo(TimeSpan.Parse(sortedArr(inner - 1, sortBy(x))))
                            Case 4 'integer
                                compareValue = CInt(sortedArr(inner, sortBy(x))).CompareTo(CInt(sortedArr(inner - 1, sortBy(x))))
                            Case 5 'string
                                compareValue = sortedArr(inner, sortBy(x)).CompareTo(sortedArr(inner - 1, sortBy(x)))
                        End Select
                        If compareValue = 0 Then
                            Continue For
                        ElseIf compareValue = -1 Then
                            Dim temp() As String = Enumerable.Range(0, sortedArr.GetLength(1)).Select(Function(i) sortedArr(inner, i)).ToArray
                            For i As Integer = 0 To temp.GetUpperBound(0)
                                sortedArr(inner, i) = sortedArr(inner - 1, i)
                                sortedArr(inner - 1, i) = temp(i)
                            Next
                        End If
                        Exit For
                    Next
                Next
            Next
    
            displayResults(outputTo)
        End Sub
    
        Private Sub displayResults(ByVal outputTo As RichTextBox)
            Dim s As String = ""
            outputTo.Text = "start"
            For n = 0 To 10
                For j = 1 To maxFields
                    s &= sortedArr(n, j) & " "
                Next
                outputTo.Text &= Chr(10) & s
                s = ""
            Next
            outputTo.Text &= Chr(10) & "end"
        End Sub
    
    End Class
    Last edited by .paul.; Apr 14th, 2015 at 09:44 PM.

  3. #3

    Thread Starter
    Junior Member
    Join Date
    Jan 2014
    Location
    Athens, Greece
    Posts
    30

    Re: VS2010 MultiDimesional Array Sort based on several criteria

    .paul.

    Thanks a lot mate, it works fine !

    Final code below.

    Code:
    ' try to sort a multi-dimensional array based on one or more criteria.
    ' here will use 3 criteria, DATE, BUS ID and DEP TIME.
    
    ' fields
    ' 1 = date
    ' 2 = bus id
    ' 3 = dep time(s)
    ' 4 = rec nbr
    ' 5 = driver id
    
    Public Class Form1
    
        ' Essential code by .paul. 14 Apr 2015 - with THANKS !
        ' http://www.vbforums.com/showthread.php?793611-VS2010-MultiDimesional-Array-Sort-based-on-several-criteria
        ' 
    
        Dim maxRec As Integer = 6
        Dim maxFields As Integer = 5
    
        Dim arr(maxRec, maxFields) As String
        Dim sortedArr(,) As String
    
        Private Sub Form1_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load
    
            Me.Text = "MultiDimesional-Array-Sort-based-on-several-criteria"
    
            '!!!remember arrays are zero based
            ' Stop using array element comparisons ( n = n-1 or n <> n-1 ) - messy indices -  as more efficient ways exist !!!
    
            arr(0, 1) = "02-Apr-2016" : arr(0, 2) = "bus-4" : arr(0, 3) = "00:20" : arr(0, 4) = "1" : arr(0, 5) = "LIN"
            arr(1, 1) = "05-Apr-2015" : arr(1, 2) = "bus-1" : arr(1, 3) = "10:45" : arr(1, 4) = "2" : arr(1, 5) = "TSA"
            arr(2, 1) = "05-Apr-2015" : arr(2, 2) = "bus-2" : arr(2, 3) = "10:30" : arr(2, 4) = "3" : arr(2, 5) = "ZIF"
            arr(3, 1) = "05-Apr-2015" : arr(3, 2) = "bus-1" : arr(3, 3) = "08:00" : arr(3, 4) = "4" : arr(3, 5) = "TSA"
            arr(4, 1) = "02-Apr-2015" : arr(4, 2) = "bus-1" : arr(4, 3) = "08:20" : arr(4, 4) = "5" : arr(4, 5) = "LIN"
            arr(5, 1) = "02-Apr-2015" : arr(5, 2) = "bus-3" : arr(5, 3) = "10:45" : arr(5, 4) = "6" : arr(5, 5) = "TSA"
            arr(6, 1) = "02-Apr-2015" : arr(6, 2) = "bus-5" : arr(6, 3) = "10:30" : arr(6, 4) = "7" : arr(6, 5) = "ZIF"
    
            ' display UNSORTED original array
    
            sortDynamically(New Integer() {0}, RichTextBox1)
    
        End Sub
    
    
        Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
    
            sortDynamically(New Integer() {1}, RichTextBox2)
            sortDynamically(New Integer() {1, 2}, RichTextBox3)
            sortDynamically(New Integer() {1, 2, 3}, RichTextBox4)
    
            MsgBox(Chr(10) & "   Sort accomplished ! " & Chr(10))
    
        End Sub
    
    
        Private Sub sortDynamically(ByVal sortBy() As Integer, ByVal outputTo As RichTextBox)
    
            Dim inner As Integer    ' create LOCAL var as per https://msdn.microsoft.com/en-us/library/bb763133.aspx
    
            sortedArr = DirectCast(arr.Clone, String(,))
    
            For outer As Integer = 0 To sortedArr.GetUpperBound(0)
    
                For avoidInnerVarCausingLambdaExpressionError As Integer = outer To 1 Step -1
    
                    ' VS2013
                    ' as per https://msdn.microsoft.com/en-us/library/bb763133.aspx
                    ' dont use directly -inner- as iteration variable ! instead...
                    ' ..Assign the value of the iteration variable to a local variable, 
                    ' and use the local variable in the lambda expression.
                    inner = avoidInnerVarCausingLambdaExpressionError
    
                    For x As Integer = 0 To sortBy.GetUpperBound(0)
    
                        Dim compareValue As Integer = 0
    
                        Select Case sortBy(x)
                            Case 1 'date
                                compareValue = CDate(sortedArr(inner, sortBy(x))).CompareTo(CDate(sortedArr(inner - 1, sortBy(x))))
                            Case 2 'integer  - bus id
                                compareValue = CInt(sortedArr(inner, sortBy(x)).Replace("bus-", "")).CompareTo(CInt(sortedArr(inner - 1, sortBy(x)).Replace("bus-", "")))
                            Case 3 'timespan - dep time
                                compareValue = TimeSpan.Parse(sortedArr(inner, sortBy(x))).CompareTo(TimeSpan.Parse(sortedArr(inner - 1, sortBy(x))))
                            Case 4 'integer  - rec nbr - must show original unsorted array (as in RichTextBox1)
                                compareValue = CInt(sortedArr(inner, sortBy(x))).CompareTo(CInt(sortedArr(inner - 1, sortBy(x))))
                            Case 5 'string   - driver id
                                compareValue = sortedArr(inner, sortBy(x)).CompareTo(sortedArr(inner - 1, sortBy(x)))
                        End Select
    
                        If compareValue = 0 Then
                            Continue For
                        ElseIf compareValue = -1 Then
                            Dim temp() As String = Enumerable.Range(0, sortedArr.GetLength(1)).Select(Function(i) sortedArr(inner, i)).ToArray
                            For i As Integer = 0 To temp.GetUpperBound(0)
                                sortedArr(inner, i) = sortedArr(inner - 1, i)
                                sortedArr(inner - 1, i) = temp(i)
                            Next
                        End If
    
                        Exit For
    
                    Next x
    
                Next avoidInnerVarCausingLambdaExpressionError
    
            Next outer
    
            displayResults(outputTo)
    
        End Sub
    
        Private Sub displayResults(ByVal outputTo As RichTextBox)
            Dim s As String = ""
            outputTo.Text = "start"
            For n = 0 To maxRec
                For j = 1 To maxFields
                    s &= sortedArr(n, j) & Space(3)   ' 3 spaces provide better readability...
                Next
                outputTo.Text &= Chr(10) & s
                s = ""
            Next
            outputTo.Text &= Chr(10) & "end"
        End Sub
    
    
    End Class
    Name:  sorting2.jpg
Views: 33
Size:  26.3 KB

Posting Permissions

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



Click Here to Expand Forum to Full Width