Option Explicit

 'ソート全体の処理
Public Sub DoSort()

    Dim strKeys             As String   'カンマ区切りのソートキー
    Dim strKeysArray()      As String   'ソートキーの配列
    Dim lngSortNum          As Long     'ソート回数
    Dim lngSortCnt          As Long     'ソートのカウンタ
    Dim lngElementPlace     As Long     'ソート時の基準となる配列の場所
    Dim strKeysParts()      As String   '一度のソートで必要なキーの配列
    Dim myRange             As Range    'ソート対象の領域
    Dim i                   As Long
    Dim lngCnt              As Long     '汎用カウンタ

    '----------------------------------------------------
    'ソートの準備

    Application.Cursor = xlWait
    Application.ScreenUpdating = False

    strKeys = "項目1,項目2,項目3,項目4,項目5,項目6,項目7,項目8,項目9,項目10" 'キーは優先度が高い順にカンマ区切りで格納する。ここは項目がいくつあっても良い。
    strKeysArray() = Split(strKeys, ",") 'それぞれのキーを配列に格納
    Set myRange = Worksheets("Sheet1").UsedRange 'ソート領域を格納（ここではUsedRangeとする）

    '一度に3つのキーまでしかソートできないため、何回ソートが必要か計算する。
    '計算式：ソート回数 = 要素数 / 3 （切り上げ）
    lngSortNum = Application.WorksheetFunction.RoundUp((UBound(strKeysArray) + 1) / 3, 0)

    '----------------------------------------------------
    '実際のソート処理を行う

    'ソート時の基準となる配列の場所を最後尾につける
    lngElementPlace = UBound(strKeysArray)

    '先程計算したソート回数分、ソート処理を繰り返す
    '※ソート処理は優先順位が低いほうから行う
    Do While lngSortCnt < lngSortNum

        If lngSortCnt < lngSortNum - 1 Then
            '「実際に行ったソート回数 < 必要なソート回数 -1 」の場合、要素3つを後ろから取り出してソートする

            ReDim strKeysParts(2)            
            lngCnt = 2  'カウンタを2にセットする

            '1度のソートで用いるキーを格納する
            For i = LBound(strKeysParts) To UBound(strKeysParts)
                strKeysParts(i) = strKeysArray(lngElementPlace - lngCnt)
                lngCnt = lngCnt - 1
            Next i

            'ソート処理を呼び出す
            Call PartSort(strKeysParts, myRange)

            'ソート時の基準となる配列の場所を3つずらす
            lngElementPlace = lngElementPlace - 3

        Else
             '「実際に行ったソート回数 = 必要なソート回数 - 1 」の場合、残りの要素を取り出してソートする

            ReDim strKeysParts(lngElementPlace)
            lngCnt = lngElementPlace

            '1度のソートで用いるキーを格納する
            For i = LBound(strKeysParts) To UBound(strKeysParts)
                strKeysParts(i) = strKeysArray(lngElementPlace - lngCnt)
                lngCnt = lngCnt - 1
            Next i

            'ソート処理を呼び出す
            Call PartSort(strKeysParts, myRange)

        End If

        'ソートのカウンタを1つ増やす
        lngSortCnt = lngSortCnt + 1

    Loop

    Application.Cursor = xlDefault
    Application.ScreenUpdating = True    
    MsgBox "ソート処理が終了しました"
End Sub

'一回のソート処理（昇順ソートを行う）
Private Sub PartSort(strKeysParts() As String, myRange As Range)

    Dim rngKeys()          As Range     'ソートキーの場所
    Dim lngEndCol          As Long      '最終列
    Dim lngTitleRow        As Long      'タイトル行
    Dim i                  As Long
    Dim rngSearch          As Range     'Findメソッドで用いるRange

    '引数のキーの要素数分ソートキーの場所（Range）を用意する
    ReDim rngKeys(UBound(strKeysParts))

    lngTitleRow = 1 '今回のタイトル行は1行目
    lngEndCol = Cells(lngTitleRow, Columns.Count).End(xlToLeft).Column '最終列を取得する

    'Findメソッドで、引数のソートキーに一致するもの（Range）を検索する
    For i = 0 To UBound(rngKeys)
        Set rngSearch = Worksheets("Sheet1").Range(Cells(lngTitleRow, 1), Cells(lngTitleRow, lngEndCol)).Find(What:=strKeysParts(i), LookAt:=xlWhole)
        If Not (rngSearch Is Nothing) Then
            Set rngKeys(i) = rngSearch
        End If
    Next i

    'キーの要素数に応じて、ソート処理を分岐して実行
    Select Case UBound(rngKeys)
        Case 0
            myRange.Sort _
                Key1:=rngKeys(0), Order1:=xlAscending, _
                Header:=xlYes
        Case 1
            myRange.Sort _
                Key1:=rngKeys(0), Order1:=xlAscending, _
                Key2:=rngKeys(1), Order2:=xlAscending, _
                Header:=xlYes
        Case 2
            myRange.Sort _
                Key1:=rngKeys(0), Order1:=xlAscending, _
                Key2:=rngKeys(1), Order2:=xlAscending, _
                Key3:=rngKeys(2), Order2:=xlAscending, _
                Header:=xlYes
    End Select      
End Sub