列だけでなくシート全体を並べ替えるように列の並べ替えを変更するにはどうすればよいですか？

範囲の問題を修正するためにいくつかの変更を加えましたが、文字列の解析はうまく機能しました

私の変更：

• メインプロシージャを新しいモジュールに移動しました
• 具体的には「MasterofMasters」のソートシートに変更しました

• ほとんどの変数の名前をもう少し直感的に変更しました

• シートオブジェクトとの相互作用を減らす

  • データをメモリに一度コピーする

  • アルゴリズムを使用して文字列を解析する

    • ただし、文字列の分割はセルや範囲ではなくメモリで行われます-パフォーマンスが向上します

  • 一度、メモリからシートにデータを戻します

• シート上のすべてのデータに並べ替えを適用する（並べ替え領域が適切に設定されていなかった）

• 一時ヘルパー列を削除します

。

これが更新されたコードです。新しいモジュールに配置してください

Option Explicit

'Place the code in a new module (from the menu: Insert -> Module)

Private Const START_COL As Byte = 1

Public Sub SortSheet(ByVal wsName As String, _
                     Optional ByVal sortCol As Long = 1, _
                     Optional ByVal row1 As Long = 2)

    Dim wb          As Workbook:    Dim ws          As Worksheet

    Dim lRow        As Long:        Dim lCol        As Long
    Dim thisRow     As Long:        Dim thisStr     As String
    Dim lastCell    As Range

    Dim sortRng     As Range:       Dim sortKey1    As Range
    Dim sortKey2    As Range:       Dim sortKey3    As Range

    Dim memArr1Col  As Variant      'column with strings         (in memory)
    Dim memArr3Col  As Variant      'helper columns, for sorting (in memory)

    Dim char        As Long:        Dim strLen      As Long
    Dim preBol      As Boolean:     Dim sufBol      As Boolean
    Dim midNum      As String
    Dim preStr      As String:      Dim sufStr      As String

    '---------------------------------------
    preBol = True
    sufBol = False
    '---------------------------------------
    With Application
        .ScreenUpdating = False
        Set wb = .ActiveWorkbook
    End With

    Set ws = Sheets(wsName)
    Set lastCell = GetMaxCell(ws.UsedRange)
    lRow = lastCell.Row
    lCol = lastCell.Column

    If row1 <= lRow Then

        With ws                             'set mem arrays: sort col, and helpers
            memArr1Col = .Range(.Cells(row1, sortCol), .Cells(lRow, sortCol))
            memArr3Col = .Range(.Cells(row1, lCol + 1), .Cells(lRow, lCol + 3))
        End With

        For thisRow = row1 - 1 To lRow - 1  'parse each cell in sort column

            If Not IsEmpty(memArr1Col(thisRow, 1)) And _
               Not IsNull(memArr1Col(thisRow, 1)) And _
               Len(memArr1Col(thisRow, 1)) > 0 Then

                thisStr = memArr1Col(thisRow, 1)
                strLen = Len(thisStr)

                For char = 1 To strLen          'parse each string
                    If preBol = True Then
                        If Not IsNumeric(Mid(thisStr, char, 1)) Then
                            preStr = preStr & Mid(thisStr, char, 1)
                            preBol = Not IsNumeric(Mid(thisStr, char + 1, 1))
                        Else
                            midNum = midNum & Mid(thisStr, char, 1)
                        End If
                    Else
                        If IsNumeric(Mid(thisStr, char, 1)) And sufBol = False Then
                            midNum = midNum & Mid(thisStr, char, 1)
                            sufBol = (Mid(thisStr, char + 1, 1)) = "-"
                        Else
                            sufStr = sufStr & Mid(thisStr, char, 1)
                        End If
                    End If
                Next   'Next character in the string
                memArr3Col(thisRow, 1) = preStr
                memArr3Col(thisRow, 2) = midNum
                memArr3Col(thisRow, 3) = sufStr & " "
                preBol = True
                sufBol = False
                midNum = vbNullString
                preStr = vbNullString
                sufStr = vbNullString
            End If
        Next   'Next Row

        With ws
            'place helper column values from memory to current worksheet
            .Range(.Cells(row1, lCol + 1), .Cells(lRow, lCol + 3)) = memArr3Col
            'set sort range - all data on this sheet plus the last 3 helper columns
            Set sortRng = .Range(.Cells(row1, START_COL), .Cells(lRow, lCol + 3))

            'set sort keys to helper columns
            Set sortKey1 = .Range(.Cells(row1, lCol + 1), .Cells(lRow, lCol + 1))
            Set sortKey2 = .Range(.Cells(row1, lCol + 2), .Cells(lRow, lCol + 2))
            Set sortKey3 = .Range(.Cells(row1, lCol + 3), .Cells(lRow, lCol + 3))
        End With

        With ws
            With .Sort  'apply the sort
                With .SortFields
                    .Clear
                    .Add sortKey1, xlSortOnValues, xlAscending
                    .Add sortKey2, xlSortOnValues, xlAscending
                    .Add sortKey3, xlSortOnValues, xlAscending
                End With
                .SetRange sortRng
                .Header = xlYes
                .Orientation = xlTopToBottom
                .Apply
            End With
            .Range( _
                    .Cells(row1, lCol + 1), _
                    .Cells(lRow, lCol + 3)).EntireColumn.Delete 'delete helper cols
            .Activate
            .Cells(1, 1).Activate
        End With
    End If
    Application.ScreenUpdating = True
End Sub

。

この関数を同じ（新しい）モジュールに配置します

Public Function GetMaxCell(Optional ByRef rng As Range = Nothing) As Range

    'Returns the last cell of range with data, or A1 if Worksheet is empty

    Const NONEMPTY As String = "*"
    Dim lRow As Range, lCol As Range

    If rng Is Nothing Then Set rng = Application.ActiveWorkbook.ActiveSheet.UsedRange
    If WorksheetFunction.CountA(rng) = 0 Then
        Set GetMaxCell = rng.Parent.Cells(1, 1)
    Else
        With rng
            Set lRow = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                   After:=.Cells(1, 1), _
                                   SearchDirection:=xlPrevious, _
                                   SearchOrder:=xlByRows)
            If Not lRow Is Nothing Then
                Set lCol = .Cells.Find(What:=NONEMPTY, LookIn:=xlFormulas, _
                                       After:=.Cells(1, 1), _
                                       SearchDirection:=xlPrevious, _
                                       SearchOrder:=xlByColumns)

                Set GetMaxCell = .Parent.Cells(lRow.Row, lCol.Column)
            End If
        End With
    End If
End Function

。

次のように、任意のSheetモジュールからmain関数を呼び出すことができます。

Option Explicit

Private Sub CommandButton1_Click()

    SortSheet wsName:="Master of Masters"

End Sub

またはこのように（デフォルトのパラメータを上書きするため）

Option Explicit

Private Sub CommandButton1_Click()

    SortSheet wsName:="Master of Masters", sortCol:=1, row1:=2

End Sub

。

ソートキーを変更するには、それに応じて次の3行を変更します。

これはPreFixでソートされます（最初のヘルパー列、次に2番目、次に3番目）：

Set sortKey1 = .Range(.Cells(row1, lCol + 1), .Cells(lRow, lCol + 1))   'PreFix: "AB"
Set sortKey2 = .Range(.Cells(row1, lCol + 2), .Cells(lRow, lCol + 2))   'Middle ID
Set sortKey3 = .Range(.Cells(row1, lCol + 3), .Cells(lRow, lCol + 3))   'PostFix

ミドルID番号（2番目のヘルパー列、1番目、3番目）で並べ替えるには：

Set sortKey1 = .Range(.Cells(row1, lCol + 2), .Cells(lRow, lCol + 2))   'Middle ID
Set sortKey2 = .Range(.Cells(row1, lCol + 1), .Cells(lRow, lCol + 1))   'PreFix: "AB"
Set sortKey3 = .Range(.Cells(row1, lCol + 3), .Cells(lRow, lCol + 3))   'PostFix

PostFixで並べ替えるには（3番目のヘルパー列、次に2番目、次に3番目）：

Set sortKey1 = .Range(.Cells(row1, lCol + 3), .Cells(lRow, lCol + 3))   'PostFix
Set sortKey2 = .Range(.Cells(row1, lCol + 2), .Cells(lRow, lCol + 2))   'Middle ID
Set sortKey3 = .Range(.Cells(row1, lCol + 1), .Cells(lRow, lCol + 1))   'PreFix: "AB"

。

私はあなたが提供したデータでそれをテストしました。結果は次のとおりです。

。

。

並べ替え中-3つのヘルパー列の文字列を解析した結果を示します