VBAで4つ以上の可変長キーに対してソート処理を行う

こんにちは、fire_waltです

前回記事を投稿してから1年半くらいが経ちました。
最近までプログラミングとは無縁の生活をしていて投稿する機会がなかったのですが、急遽マクロ開発をする機会が訪れたので、そこで得た知識を共有したいと思います。

今回は、エクセルVBAで可変長キーに対してソート処理を行う、というものです。4つ以上のキーに対してもソートができることを強調するために、あえて「4つ以上」とタイトルには記載していますが、3つ以下でも通用するコードです。

可変長のキーに対してソートを実行するコードがあまりネット上になかったため、今回自作しました。

仕様

• 可変長のキーに対して昇順ソートを行う（4つ以上のキーにも対応）

なお、ソートに使用したエクセル、およびソート処理後のエクセルの外観は下記の通りです。
【ソート処理前の外観】

【ソート処理後の外観（ソートキーは優先順に「項目1～項目10」とした）】

前提知識

そもそもVBAの標準機能では、最大3つまでのキーに対してしかソートすることができません。しかし、少し工夫をすることで、4つ以上のキーに対してもソートをすることができます。その詳細は「VBAで4つ以上のキーでソートする方法」をググるといくつか出てきますが、主な流れは以下の通りです。

（例）4つのキー（優先順位：A, B, C, D）でソートをする場合：
　1. ソートの優先順位の低い順から数えてキーを3つ取り出し（B, C, D）、ソート処理をかける。
　2. 残りのAに対してソート処理をかける。

上の例を応用すると、N個のキーに対しても同様にソートをすることができます。
N個のキーでソートする場合：
　1. ソートの優先順位の低い順から数えてキーを3つ取り出してソート処理をかける。
　2. 「1.」の処理を最後のソート処理を行う前まで繰り返す。
　3. 最後のソート処理では残りのキーが3つの場合、2つの場合、1つの場合が存在するため、必要な個数のソートキーを取り出してソート処理をかける。

本記事では、この「N個のキーでソートする場合」の流れを利用してコードを書いています。

ソースコード

作成したソースコードです。

mdlSort

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

最後に

私は本業プログラマではありませんが、多くの方々がネット上に知見を共有してくださっているからこそ、必要な情報を検索でき、こんな私でもプログラムを組むことができています。私も得た知見を共有することで、少しでもITコミュニティに恩返しできればと考えています！