Question

我想对一个多维数组进行排序，该数组在第一列中包含名称值，在第二列中包含日期/时间。我想从Microsoft Excel电子表格中检索值并通过Visual Basic for Applications执行所有操作，然后将其放在另一个电子表格中并执行条件格式设置。整个数组不会进入新的电子表格。

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

Answer 1

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

对数组进行排序后，只需创建一个循环，将所需值的特定数组位置粘贴回工作表。

在Visual Basic for Applications中对多维数组进行排序

1 个答案: