プルダウンリストを作成する ④ 表示する順序を指定 の続き

先日は、プルダウンリストを作成する際に、リストの表示順序を明示する方法を考えてみた。
infoment.hatenablog.com

この中で、二次元配列のソートを突貫工事で作成したところ、なかなかの欠陥物件になってしまった。
※数字を文字に置き換える過程で、正しくソートされなくなる。等々。

そこで今日は、前回、前々回の内容と合わせて、この問題解決に挑戦する。

元となる表がコチラ。

以下は全て配列を用いて行っているが、視覚化のためシート上で表現している。
まず空欄に、記入済み通し番号の続きを上から順に付す。

この表示列の最大値を求め、さらにその桁数を求める。
このとき表示列が全て文字列ならば、最大値は０となる。

求めた桁数分、10を掛け算する。

表の各行を、「,」でつなげる。

ソートする列の各値に、先程求めた「100」を加えたものを準備する。この時、足される側が数字でない場合は、その文字のままとする。
例）
１　⇒　１０１
ａ　⇒　ａのまま

求めた値を、先程の先頭に追加する。

これを、昇順でソートする。
先頭の数値は桁が揃えてあるため、1 ⇒ 10 ⇒ 2 のような逆転は起きない。
（101 ⇒ 102 ⇒ ・・・ ⇒ 110 の順になる）。

先頭の要素を取り除いたうえで、二次元配列に戻す。

一列目を抜き出し、JOIN関数でカンマ区切りの文字列を作成する。

この文字列を、入力規則のリストとして設定する。

出来た。

前置きが長くなりましたが、そんな僕らのコードをご覧ください（「ナイツの漫才」風）。

クラスモジュール（SeaquenceClass）

' 一次元配列ソート

Public Function SortArray(ByVal arr As Variant, _
                       Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
    Dim aryList As Object
    Dim s As Variant
    Set aryList = CreateObject("System.Collections.ArrayList")

    For Each s In arr
        Call aryList.Add(s)
    Next

    Select Case sort_order
        Case xlAscending
            ' 昇順でソート。
            Call aryList.Sort
        Case xlDescending
            ' 昇順でソートののち、降順へ反転。
            Call aryList.Sort
            Call aryList.Reverse
    End Select

    SortArray = aryList.ToArray
End Function

' 二次元配列ソート（今回改修した箇所）

Public Function SortArray2D(ByVal arr As Variant, _
                         Optional sort_column As Long = 1, _
                         Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant

    ' 各行要素を一次元配列として抽出し、ソートしたい列の値を付して「,」で結合｡
    ' これらで構成された一次元を作成する。
    ' ※列のデータを、一番左のセルにギュッと寄せて、ソートしたい列の値を先頭に付すイメージ｡
    Dim TempArray() As Variant
    ReDim TempArray(LBound(arr) To UBound(arr))
    Dim RowArray As Variant
    Dim SortKey As String
    Dim i As Long

    ' ソート列を抜き出して新たな配列を作成し、配列内の最大値を求める。
    Dim cMax As Long
        cMax = WorksheetFunction.Max(ExtractArray2(arr, sort_column))
    
    ' 最大値の桁数ｄを求め、１０のｄ乗の数を求める。
    ' これをソートする列に加えることで、文字列であっても数字と
    ' 同じソート結果を得られる。
    Dim d As Long
        d = DigitNumber(cMax)
    Dim AdjustNumber As Long
        AdjustNumber = 10 ^ d
    Dim AdditionalCharacter As Variant
    
        For i = LBound(arr) To UBound(arr)
            RowArray = ExtractArray2(arr, i, i)
            AdditionalCharacter = arr(i, sort_column)
            If IsNumeric(AdditionalCharacter) Then
                AdditionalCharacter = AdjustNumber + AdditionalCharacter
            End If
            TempArray(i) = AdditionalCharacter & "," & Join(RowArray, ",")
        Next

    ' 一次元配列としてソート。
        TempArray = SortArray(TempArray, sort_order)

    ' ソートした結果を再び分割し、新たな配列に振りなおす。
    Dim DestinationArray() As Variant
    ReDim DestinationArray(LBound(arr) To UBound(arr), LBound(arr, 2) To UBound(arr, 2))
    Dim j As Long
        For i = LBound(TempArray) To UBound(TempArray)
            RowArray = Split(TempArray(i), ",")

            ' ０番目の要素はソート用であるため不要 ⇒ １番目からループ。
            For j = 1 To UBound(RowArray)
                DestinationArray(LBound(arr) + i, LBound(arr) + j - 1) = RowArray(j)
            Next
        Next

        SortArray2D = DestinationArray

End Function

' 二次元配列内の任意の範囲を、新たな配列として返す関数

' sorce_array   抽出元の配列
' r_min         一次元要素の下限
' r_max         一次元要素の上限
' c_min         二次元要素の下限
' c_max         二次元要素の上限
' to_1d_flag    一次元または二次元の上限と下限が一致する場合、
'               抽出後の配列を一次元配列に変換するか否かのフラグ。
Function ExtractArray2(ByVal sorce_array As Variant, _
             Optional r_min As Long = -1, _
             Optional r_max As Long = -1, _
             Optional c_min As Long = -1, _
             Optional c_max As Long = -1, _
             Optional to_1d_flag As Boolean = True) As Variant

        ' 二次元配列であることの確認
        If GetArrayDimension(sorce_array) <> 2 Then
            ExtractArray2 = Array(): Exit Function
        End If

        ' 下限確認。
        ' 指定下限が無指定の場合、抽出元配列の下限を指定下限とする。
        ' ※指定下限が指定上限を上回る場合については、指定上限側で対処する。
        ' 指定下限が負の値の場合、指定下限を０とする。
        ' 指定下限が抽出元配列の下限を下回る場合、これを認める。
        If r_min = -1 Then
            r_min = LBound(sorce_array, 1)
        ElseIf r_min < 0 Then
            r_min = 0
        End If

        If c_min = -1 Then
            c_min = LBound(sorce_array, 2)
        ElseIf c_min < 0 Then
            c_min = 0
        End If

        ' 上限確認。
        ' 指定上限が無指定の場合、抽出元配列の上限を指定上限とする。
        ' 指定上限が指定下限を下回る場合、指定下限を指定上限とする。
        ' 指定上限が抽出元配列の上限を上回る場合、これを認める。
        If r_max = -1 Then
            r_max = UBound(sorce_array, 1)
        ElseIf r_max < r_min Then
            r_max = r_min
        End If

        If c_max = -1 Then
            c_max = UBound(sorce_array, 2)
        ElseIf c_max < c_min Then
            c_max = c_min
        End If

    ' 抽出用配列。
    Dim TempArray() As Variant
    ReDim TempArray(1 To r_max - r_min + 1, 1 To c_max - c_min + 1)

    Dim r As Long
    Dim C As Long

        ' 値抽出。
        For r = r_min To r_max
            For C = c_min To c_max
                On Error Resume Next
                TempArray(r - r_min + 1, C - c_min + 1) = sorce_array(r, C)
            Next
        Next

        ' １行または１列の配列の場合、二次元配列を一次元配列に変換。
        ' ※to_1d_flag = True の場合のみ
        If to_1d_flag Then
            If UBound(TempArray, 2) = 1 Then
                TempArray = WorksheetFunction.Transpose(TempArray)
            ElseIf UBound(TempArray, 1) = 1 Then
                TempArray = WorksheetFunction.Transpose(TempArray)
                TempArray = WorksheetFunction.Transpose(TempArray)
            End If
        End If

        ExtractArray2 = TempArray
End Function

' 配列の次元数を求める関数

Private Function GetArrayDimension(arr As Variant) As Long

    If IsArray(arr) = False Then
        GetArrayDimension = -1
        Exit Function
    End If

    ' 配列の次元数を取得。

    Dim i As Long
    Dim TempNumber As Long

        On Error Resume Next
        Do While Err.Number = 0
            i = i + 1
            TempNumber = UBound(arr, i)
        Loop

        GetArrayDimension = i - 1

End Function

' 桁数を求める関数　※有効数字のそれと異なることに注意

Function DigitNumber(num As Variant) As Long
    Dim i As Long: i = 10
    Dim j As Long: j = 1
        Do
            If num / i < 1 Then
                DigitNumber = j
                Exit Function
            Else
                i = i * 10
                j = j + 1
            End If
        Loop
End Function

標準モジュール

' リスト設定用

Sub SetList(target_range As Range, arr As Variant)
    target_range.Validation.Delete
    target_range.Validation.Add Type:=xlValidateList, _
                                AlertStyle:=xlValidAlertStop, _
                                Operator:=xlBetween, _
                                Formula1:=Join(arr, ",")
End Sub

' リスト用配列作成

Function ListArray(target_table As ListObject, _
                   item_column As Long, _
                   sort_column As Long) As Variant
    Dim arr As Variant
        arr = target_table.DataBodyRange
    Dim myMax As Long
        myMax = WorksheetFunction.Max(target_table.DataBodyRange.Columns(sort_column)) + 1
    Dim i As Long
        For i = 1 To UBound(arr)
            If arr(i, sort_column) = vbNullString Then
                arr(i, sort_column) = myMax
                myMax = myMax + 1
            End If
        Next
    
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
        arr = SQC.SortArray2D(arr, sort_column)
    ListArray = SQC.ExtractArray2(arr, , , item_column, item_column)
End Function

' テスト

Sub test()
    Dim Tb As ListObject
    Set Tb = ActiveSheet.ListObjects(1)
    Dim arr As Variant
        arr = ListArray(Tb, 1, 2)
    SetList Selection, arr
End Sub

前回テスト内で行っていた強引な辻褄合わせを、クラスモジュール内に取り込んだかたち。

なので依然として、このような手法が正しいかどうかは定かでありません。

参考まで。