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

昨日は、プルダウンリストに表示する選択肢について、全候補からユーザーが任意に、事前に絞り込んでおく方法を考えてみた。
infoment.hatenablog.com

しかしこの方法には、重大な欠陥がある。それは、絞り込まれて表示されなかった選択肢を、この仕掛けを知らない第三者が見たときに知り得ない点だ。そこで今日は、この欠陥の解消に挑戦する。

もともと、使用頻度の高い順に表を並べておけば、自ずとドロップダウンリストもそれに倣う。その場合はマクロを使う必要も無いのだが、並び替えが許されない場合もあるだろう。ならば、一旦配列に格納し、マクロで並び替えしてみよう。

今回のために突貫で、二次元配列ソートを含むクラスモジュールを作成した。

クラスモジュール（SeaquenceClass）

最初の三つは、今までにも何度か登場している。
① 配列の次元数取得

'［用　途］
'   配列の次元数取得
'［引　数］
'   arr As Variant  配列
'［戻り値］
'   正常終了    配列の次元数
'   -1の場合    異常終了　※つまり、seqは配列ではない
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

② 配列から任意の値を抽出して、新たな配列を作成

' 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

③ 一次元配列のソート

'［用　途］
'   配列ソート
'［引　数］
'   arr As Variant          ソート前の配列
'   sort_type As Excel.XlSortOrder  昇順 or 降順　※初期値：昇順
'［戻り値］
'   ソート後の配列
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

④ 二次元配列のソート　※今回作成

'［用　途］
'   二次元配列ソート
'［引　数］
'   arr As Variant          ソート前の配列
'   sort_column as long     ソートする列番号
'   sort_type As Excel.XlSortOrder  昇順 or 降順　※初期値：昇順
'［戻り値］
'   ソート後の配列
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
        For i = LBound(arr) To UBound(arr)
            RowArray = ExtractArray2(arr, i, i)
            TempArray(i) = arr(i, sort_column) & "," & 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

それでは、こちらでテストしてみよう。

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() As Variant
    Dim arr As Variant
        arr = ActiveSheet.ListObjects(1).DataBodyRange
        
    For i = 1 To UBound(arr)
        If arr(i, 2) = vbNullString Then
            arr(i, 2) = (UBound(arr) + 1) / 100
        Else
            arr(i, 2) = arr(i, 2) / 100
        End If
    Next
    
    Dim SQC As SeaquenceClass
    Set SQC = New SeaquenceClass
        arr = SQC.SortArray2D(arr, 2)
    ListArray = SQC.ExtractArray2(arr, , , 1, 1)
End Function

Sub test()
    SetList Selection, ListArray
End Sub

結果、番号を指定した選択肢は、指定した順で上位に並んでくれた。

しかし、番号を振っていない選択肢の順序が、元々の並びと比較して滅茶苦茶になってしまった。また突貫の悲しさ、並び順を指定した数字が文字列として認識されるため、例えば
「１，２，３，・・・，９，１０」
は、ソートすると
「１，１０，２，３・・・」
のようにおかしな並びになる不具合発生。今回は100で割ることで先頭に「0.」を付し強引に解決したが、後日、もう少しスマートな方法を模索してみるとしよう。

参考まで。