Sort a Multi-Dimensional Array

K

KhmerBoi1

New Member
Joined
Aug 12, 2014
Messages
30
Request to know how to sort a Multi-Dimensional Array. Below is the provided code in which I looped through a range of cells and stored a Name and Date/Time in Multi-Dimensional Array. How could I sort the array without throwing it back into a spreadsheet?

Code: 
Sub ListPlatformSyncDates()
'===============================================================================================
'Description: Selects the entire row for all selected cells and then hides them.
'Originally written by: Troy Pilewski
'Date: 2015-05-12
'Modified by: Troy Pilewski
'Modified on: 2016-02-01
'===============================================================================================

'Declaration of variables for use during the procedure
Dim wsSheet As Worksheet
Dim lngLastRow As Long, lngLastNOC As Long, lngLastShip As Long, RowTotal As Long

'Changes the state of the application events
Call TOGGLEEVENTS(False)

'Exits the procedure is no workbook is open
If ActiveSheet Is Nothing Then
    Exit Sub
End If

'Sets the sheets the variables
Set wsSheet = ActiveSheet

'Determine the last row with values
lngLastRow = wsSheet.Range("A:L").Find( _
    What:="*", _
    After:=wsSheet.Range("A1"), _
    LookAt:=xlByRows, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious _
).Row
lngLastNOC = wsSheet.Range("A1:A" & lngLastRow - 15).Find( _
    What:="_", _
    After:=wsSheet.Range("A1"), _
    LookAt:=xlPart, _
    SearchOrder:=xlByRows, _
    SearchDirection:=xlPrevious _
).Row

'Debug.Print lngLastRow
'Debug.Print lngLastNOC

'Set the last row of the reported platforms
lngLastShip = lngLastRow - 15

RowTotal = lngLastShip - lngLastNOC

On Error Resume Next

'Declares variables for use with the chooser form
Dim ClassificationLevel(1) As String, ClassificationSelection As String

'Assigns the two classifications to the String Array
ClassificationLevel(0) = "Non-Secure Internet Protocol Router Network"
ClassificationLevel(1) = "Secure Internet Protocol Router Network"

'Prompts the user to select a classification
ClassificationSelection = GetChoiceFromChooserForm(ClassificationLevel(), "Classification Level")

Select Case ClassificationSelection
    Dim loopCounter As Long, CharPos As Long
    Dim ship As Range
    Dim FullShipName, strFullShipName As String, SplitShipName, NamePart
    Case "Non-Secure Internet Protocol Router Network"
        ReDim NTable(RowTotal, 1) As String
        loopCounter = lngLastNOC + 1
        For Each ship In Range("B" & loopCounter & ":B" & lngLastShip)
            With Application
                .DisplayStatusBar = True
                .StatusBar = "Working with the " & Range("B" & loopCounter)
            End With
            FullShipName = Split(Replace(WorksheetFunction.Clean(ship), Chr(160), Chr(32)), Chr(32))
            If UBound(FullShipName) > 0 Then
                If Left(FullShipName, 2) = "US" Or Left(FullShipName, 2) = "PC" Then
                    FullShipName(0) = Chr(32)
                End If
                strFullShipName = Trim(Join(FullShipName, Chr(32)))
                If InStr(strFullShipName, Chr(46)) > 0 Then
                    SplitShipName = Split(strFullShipName, Chr(32))
                    For Each NamePart In SplitShipName
                        If InStr(NamePart, Chr(46)) > 0 Then
                            NamePart = UCase(NamePart)
                        End If
                    Next
                    strFullShipName = Trim(Join(SplitShipName, Chr(32)))
'                    Debug.Print strFullShipName
                    If InStr(strFullShipName, Chr(40)) > 0 Then
                        CharPos = InStr(strFullShipName, Chr(40))
                        strFullShipName = Left(strFullShipName, CharPos - 1) & Chr(33) & Mid(strFullShipName, CharPos)
                        SplitShipName = Split(strFullShipName, Chr(33))
                        If UBound(SplitShipName) > 0 Then
                            SplitShipName(1) = UCase(SplitShipName(1))
                        End If
                        strFullShipName = Trim(Join(SplitShipName))
'                        Debug.Print strFullShipName
                    End If
                    NTable(loopCounter - 13, 0) = strFullShipName
                    NTable(loopCounter - 13, 1) = Range("C" & loopCounter)
                ElseIf InStr(strFullShipName, Chr(40)) > 0 Then
                        CharPos = InStr(strFullShipName, Chr(40))
                        strFullShipName = Left(strFullShipName, CharPos - 1) & Chr(33) & Mid(strFullShipName, CharPos)
                        SplitShipName = Split(strFullShipName, Chr(33))
                        If UBound(SplitShipName) > 0 Then
                            SplitShipName(1) = UCase(SplitShipName(1))
                        End If
                        strFullShipName = Trim(Join(SplitShipName))
'                        Debug.Print strFullShipName
                    NTable(loopCounter - 13, 0) = strFullShipName
                    NTable(loopCounter - 13, 1) = Range("C" & loopCounter)
                Else
                    strFullShipName = StrConv(strFullShipName, vbProperCase)
'                    Debug.Print strFullShipName
                    NTable(loopCounter - 13, 0) = strFullShipName
                    NTable(loopCounter - 13, 1) = Range("C" & loopCounter)
                End If
            End If
            Debug.Print NTable(loopCounter - 13, 0) & Chr(32) & NTable(loopCounter - 13, 1)
            loopCounter = loopCounter + 1
        Next ship
    Case "Secure Internet Protocol Router Network"
        ReDim STable(RowTotal, 1) As String
        loopCounter = lngLastNOC + 1
        For Each ship In Range("B" & loopCounter & ":B" & lngLastShip)
            With Application
                .DisplayStatusBar = True
                .StatusBar = "Working with the " & Range("B" & loopCounter)
            End With
            FullShipName = Split(Replace(WorksheetFunction.Clean(ship), Chr(160), Chr(32)), Chr(32))
            If UBound(FullShipName) > 0 Then
                If Left(FullShipName, 2) = "US" Or Left(FullShipName, 2) = "PC" Then
                    FullShipName(0) = Chr(32)
                End If
                strFullShipName = Trim(Join(FullShipName, Chr(32)))
                If InStr(strFullShipName, Chr(46)) > 0 Then
                    SplitShipName = Split(strFullShipName, Chr(32))
                    For Each NamePart In SplitShipName
                        If InStr(NamePart, Chr(46)) > 0 Then
                            NamePart = UCase(NamePart)
                        End If
                    Next
                    strFullShipName = Trim(Join(SplitShipName, Chr(32)))
'                    Debug.Print strFullShipName
                    If InStr(strFullShipName, Chr(40)) > 0 Then
                        CharPos = InStr(strFullShipName, Chr(40))
                        strFullShipName = Left(strFullShipName, CharPos - 1) & Chr(33) & Mid(strFullShipName, CharPos)
                        SplitShipName = Split(strFullShipName, Chr(33))
                        If UBound(SplitShipName) > 0 Then
                            SplitShipName(1) = UCase(SplitShipName(1))
                        End If
                        strFullShipName = Trim(Join(SplitShipName))
'                        Debug.Print strFullShipName
                    End If
                    STable(loopCounter - 13, 0) = strFullShipName
                    STable(loopCounter - 13, 1) = Range("F" & loopCounter)
                ElseIf InStr(strFullShipName, Chr(40)) > 0 Then
                        CharPos = InStr(strFullShipName, Chr(40))
                        strFullShipName = Left(strFullShipName, CharPos - 1) & Chr(33) & Mid(strFullShipName, CharPos)
                        SplitShipName = Split(strFullShipName, Chr(33))
                        If UBound(SplitShipName) > 0 Then
                            SplitShipName(1) = UCase(SplitShipName(1))
                        End If
                        strFullShipName = Trim(Join(SplitShipName))
'                        Debug.Print strFullShipName
                    STable(loopCounter - 13, 0) = strFullShipName
                    STable(loopCounter - 13, 1) = Range("F" & loopCounter)
                Else
                    strFullShipName = StrConv(strFullShipName, vbProperCase)
'                    Debug.Print strFullShipName
                    STable(loopCounter - 13, 0) = strFullShipName
                    STable(loopCounter - 13, 1) = Range("F" & loopCounter)
                End If
            End If
            Debug.Print STable(loopCounter - 13, 0) & Chr(32) & STable(loopCounter - 13, 1)
            loopCounter = loopCounter + 1
        Next ship
End Select
End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Sort by date Sort by votes
The easiest way by far is to put it on a worksheet (a temporary sheet if necessary), sort it there, and read it back in.

An alternative is to do an index sort (one that returns the sorted order of the records) and use that to rearrange the array.
 
Last edited:
Upvote 0
shg said:
The easiest way by far is to put it on a worksheet (a temporary sheet if necessary), sort it there, and read it back in.

An alternative is to do an index sort (one that returns the sorted order of the records) and use that to rearrange the array.
Click to expand...

How would you do the index sort? The reason I don't want to throw it back on to a spreadsheet is because I will be throwing the sorted data back onto a spreadsheet.
 
Upvote 0
If you're putting the sorted data back on the sheet, why not do that first, then sort?
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Help Cleaning Up / Optimizing VBA Code
Replies
6
Views
281
offthelip
O
T
  • Question
Help with clearing array
Replies
0
Views
285
ToExcelOrNotToExcel
T
M
  • Question
Excel VBA Dowload Sharepoint File MSXML2.XMLHTTP.6.0 ResponseBody Error
Replies
0
Views
2K
mmhill
M
K
  • Question
Auto Sort (Descinding) based on a column header using VBA
Replies
1
Views
92
Fluff
Fluff
R
  • Question
Cell jumping from active cell to the one above after macro
Replies
0
Views
427
Rxm177
R

Forum statistics

Threads
1,214,808
Messages
6,121,681
Members
449,048
Latest member
81jamesacct

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top