エクセルマクロＶＢＡ　住所リストの行列を操作したい Add Star

こんな感じですかね

Option Explicit

Private Const SHIPMENT_COL      As Long = 2

Private Const WINNING_BID_COL   As Long = 3

Private Const TOTAL_COL         As Long = 5

Private Const ADDRESS_COL   As Long = 9

Private Const HEADER_ROWS   As Long = 1


Public Sub sortByMyRule()

    Const TARGET_SHEET_NAME As String = "Sheet1"

    Dim ws      As Worksheet
    Dim lEndRow As Long

    '処理対象ワークシート
    Set ws = ThisWorkbook.Worksheets(TARGET_SHEET_NAME)

    '住所列の最終行取得
    lEndRow = ws.Cells(1, ADDRESS_COL).End(xlDown).Row

    '住所と計で並べ替え
    Call sortByAddressAndTotal(ws, lEndRow)

    '「発送」への番号付与、「落札」「送料」「計」クリア
    Call editItemValue(ws, lEndRow)

    '「発送」をグループ化するため再度並べ替え
    Call groupByShipment(ws, lEndRow)

    Set ws = Nothing

End Sub

Private Sub sortByAddressAndTotal(ByRef ws As Worksheet, ByVal lEndRow As Long)

    '「計」補正用列挿入
    ws.Columns(TOTAL_COL + 1).Insert

    '「計」での並べ替え用補正値の計算式設定
    With ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1)
        .FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),RC[-1],0)"
        .AutoFill Destination:=ws.Range(ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1), ws.Cells(lEndRow, TOTAL_COL + 1)), Type:=xlFillDefault
    End With

    '並べ替え
    With ws.Sort
        With .SortFields
            .Clear
            '計補正用列があるため、並べ替えの基準列を１オフセットする
            .Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, ADDRESS_COL + 1), ws.Cells(lEndRow, ADDRESS_COL + 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, TOTAL_COL + 1), ws.Cells(lEndRow, TOTAL_COL + 1)), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
        End With

        .SetRange ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, ws.Columns.Count))
        .Apply
    End With

    '「計」補正用列削除
    ws.Columns(TOTAL_COL + 1).Delete

End Sub

Private Sub editItemValue(ByRef ws As Worksheet, ByVal lEndRow As Long)

    Dim lCurrentRow     As Long
    Dim lBeginRow       As Long
    Dim sCurrentAddress As String
    Dim lItems          As Long
    Dim sPrefix         As String
    Dim i               As Long

    lCurrentRow = HEADER_ROWS + 1

    lBeginRow = lCurrentRow

    With ws
        Do Until lCurrentRow > lEndRow
            sCurrentAddress = .Cells(lCurrentRow, ADDRESS_COL).Value

            lItems = 1

            Do While (sCurrentAddress = .Cells(lCurrentRow + lItems, ADDRESS_COL).Value)
                lItems = lItems + 1
            Loop

            If lItems > 1 Then
                sPrefix = Left$(.Cells(lBeginRow, SHIPMENT_COL).Value, 1)

                For i = 1 To lItems - 1
                    '発送へ番号付与
                    .Cells(lBeginRow + i, SHIPMENT_COL).Value = sPrefix & CStr(i + 1)
                Next i

                '落札、送料、計クリア
                 .Range(.Cells(lBeginRow + 1, WINNING_BID_COL), .Cells(lBeginRow + lItems - 1, TOTAL_COL)).ClearContents
            End If

            lCurrentRow = lCurrentRow + lItems

            lBeginRow = lCurrentRow
        Loop
    End With

End Sub

Private Sub groupByShipment(ByRef ws As Worksheet, ByVal lEndRow As Long)

    With ws
        '「発送」グループ化用データ列挿入
        .Columns(1).Insert
        .Columns(1).Insert

        '現在の並び順の番号を生成
        .Cells(HEADER_ROWS + 1, 1) = 1
        .Cells(HEADER_ROWS + 2, 1) = 2

        .Range(.Cells(HEADER_ROWS + 1, 1), .Cells(HEADER_ROWS + 2, 1)).AutoFill Destination:=.Range(.Cells(HEADER_ROWS + 1, 1), .Cells(lEndRow, 1)), Type:=xlFillDefault

        '「発送」の先頭１文字抽出
        .Cells(HEADER_ROWS + 1, 2).FormulaR1C1 = "=LEFT(RC[2],1)"
        .Cells(HEADER_ROWS + 1, 2).AutoFill Destination:=.Range(.Cells(HEADER_ROWS + 1, 2), .Cells(lEndRow, 2)), Type:=xlFillDefault
    End With

    '並べ替え
    With ws.Sort
        With .SortFields
            .Clear
            .Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, 2), ws.Cells(lEndRow, 2)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .Add Key:=ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, 1)), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With

        .SetRange ws.Range(ws.Cells(HEADER_ROWS + 1, 1), ws.Cells(lEndRow, ws.Columns.Count))
        .Apply
    End With

    '「発送」グループ化用データ列削除
    ws.Columns(2).Delete
    ws.Columns(1).Delete

End Sub