안녕하세요, 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 커뮤니티에 은혜를 줄 수 있다고 생각합니다!