Sort Multi-Dimensional Arrays in Visual Basic for Applications

Question

I would like to sort a Multi-Dimensional Array holding a name value in the first column and a date/time in the second. I would like to retrieve value from a Microsoft Excel Spreadsheet and perform all manipulations via Visual Basic for Applications and then place it in another spreadsheet and perform conditional formatting. The entire array will not be going onto the new spreadsheet.

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

this might sound like a silly question but as I am a newby....: Is a multidimensional array an array which contains as values another arrays? — Kathara, Feb 09 '16 at 14:42
In my experience, a multi-dimensional array is like a regular array but with multiple columns — TroyPilewski, Feb 09 '16 at 16:02
You gave us a wall of code but no clear question. What, exactly, are you asking? — John Coleman, Feb 09 '16 at 16:06
I would like to know how to take the multi-dimensional arrays {NTable and STable} and sort them by date. I managed to get everything into the array but not sure how to sort it once all data is stored in the array. As well as I only want to to put part of the array back onto a spreadsheet once sorted, not the entire array. Thus I want to sort prior to putting to values back into a spreadsheet. — TroyPilewski, Feb 09 '16 at 16:10
@JohnColeman: I was only asking how to sort the array. "_As well as I only want to to put part of the array back onto a spreadsheet once sorted, not the entire array. Thus I want to sort prior to putting to values back into a spreadsheet._" was only to provide justification as to why I did not want to put the array into a spreadsheet and then sort. — TroyPilewski, Feb 09 '16 at 16:47

score 0 · Answer 1 · edited May 23 '17 at 11:52

0

Here is a link to a previous question regarding how to sort an array.

Once you sort the array, just create a loop to paste the specific array positions of your desired values back into the worksheet.

edited May 23 '17 at 11:52

Community

1
1

answered Feb 09 '16 at 16:27

Dan

425
2
13

score 0 · Answer 2 · answered Dec 06 '21 at 23:35

You could sort the values in the array using the bubble method:

Dim i as integer
Dim j as integer
Dim aux as string
Dim dtAux as string
Dim arraySize as integer


arraySize = Ubound(Ntable(1,1) - LBound (Ntable(1,1)) + 1

For i=0 to arraySize
   For j=0 to arraySize-i-1
      'Change < or > accordingly
      if Ntable(i,1) > Ntable(i+1,1) then
         'Save values of element being compared to the rest
         aux=Ntable(j+1,1)
         dtAux=Ntable(j+1,2)
         'Swap positions bu changing the values
         Ntable(j,1)=Ntable(j+1,1)
         Ntable(j,2)=Ntable(j+1,2)
         Ntable(j+1,1)=aux
         Ntable(j+1,2)=dtAux
     end if 
   Next j
Next i

After that all you need to do is copy the array to the destination worksheet. One more thing you could do is to paste the array with the values you want on the destination table and just sort that with something like this:

Range("B1:B500").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:=xlNo

Sort Multi-Dimensional Arrays in Visual Basic for Applications

2 Answers2