ListBoxを操作するクラスモジュール ⑤ 検索値を含む行のみでリストボックスを更新

ListBoxを操作するクラスモジュールを、私なりに作成中。
前回は、選択行の指定列の値を返すことに挑戦した。
infoment.hatenablog.com

今日も、前回の続きから。

ListBoxについて個人的に、今まで何度か需要があったのがこちら。

指定キーワードで、リストボックス内のリストを絞り込み

そこで、キーワードを含む行だけでリストボックスを更新することにした。
するとここで、今までの作りでは都合が悪いことに気づく。なぜなら、今の
作りでは常に、リストボックス作成時の配列を処理のメインに使用していた
ため、絞り込んだり元に戻したりに向いていないのだ。

そこで、初期の配列はそれとして保存し、現在のリストボックスを現わす
配列を別に設けたうえで、リストを更新する関数を新たに作成してみた。

というわけで今日は、クラスモジュールの全文を紹介する。リスト更新の
箇所については、その末尾を参照されたし。

クラスモジュール（ListBoxControl）

Option Explicit

' 対象となるリストボックス。
Public TargetListBox As MSForms.ListBox

' リストとして与えられた配列（二次元配列）。
' 一次元配列は、複数行１列の二次元配列に変換後のもの。
' またインデックスは、行と列ともに０始まりへ矯正後のもの。
Private SourceListArray() As Variant

' 最新のリスト内容を反映した二次元配列。
' 値の取得や絞り込みなどは常に、まず配列を作成したうえで
' リストボックスに結果を返すものとする。
Public LatestListArray As Variant

' ループ用整数。
Private i As Long
Private j As Long

' リスト用に与えられた配列の次元数。
Private DimensionNumber As Long

Private Sub Class_Initialize()

    ' リストボックスに渡した配列の次元数。
    ' 初期値は一次元配列とする。
    DimensionNumber = 1

End Sub

' リストボックスにリストをセット。
Public Sub InitializeList(ByVal source_list_array As Variant)

    ' 仮の配列。
    Dim Temp As Variant
        ' list_arrayが配列なら、そのままTempにセット。
        ' 配列でないならば、一旦配列化したのちセット。
        If IsArray(source_list_array) Then
            Temp = source_list_array
        Else
            Temp = Array(source_list_array)
        End If
        TargetListBox.List = Temp
    
        ' 配列のインデックスについて、最小値を一旦
        ' 「1」としたい。
        ' 配列が一次元の場合、Transpose関数で一旦行列を反転させると、
        ' インデックスの最小値が１の、複数行１列の二次元配列になる。
        Temp = WorksheetFunction.Transpose(Temp)
        
        ' 二次元目のインデックス最大値が１で無い場合、配列は元から
        ' 二次元配列ということになる。したがって、行列を反転して元に戻す。
        ' またこの時点で、元の配列のインデックス最小値が何であっても、
        ' 行と列ともに１から始まる配列となる。
        If UBound(Temp, 2) <> 1 Then
            Temp = WorksheetFunction.Transpose(Temp)
            DimensionNumber = 2
        End If
        
        ' リストボックスのリストと同じ構成の二次元配列を作成する。
        ' リストボックスは行列共に０始まりであるため、下記でその
        ' ギャップを解消している。
    ReDim SourceListArray(UBound(Temp) - 1, UBound(Temp, 2) - 1)
        For i = 0 To UBound(SourceListArray)
            For j = 0 To UBound(SourceListArray, 2)
                SourceListArray(i, j) = Temp(i + 1, j + 1)
            Next
        Next
        
        ' 初回であるため、最新のリストを元のリストとする。
        LatestListArray = SourceListArray

End Sub

' リストボックスのリストを更新。
Public Sub UpdateList(ByVal list_array As Variant)

    ' 仮の配列。
    Dim Temp As Variant
        ' list_arrayが配列なら、そのままTempにセット。
        ' 配列でないならば、一旦配列化したのちセット。
        If IsArray(list_array) Then
            Temp = list_array
        Else
            Temp = Array(list_array)
        End If
        TargetListBox.List = Temp

End Sub

' 選ばれた行のインデックスが格納された配列。
Public Property Get SelectedIndex() As Variant
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
        For i = 0 To TargetListBox.ListCount - 1
            If TargetListBox.Selected(i) Then
                Dict(i) = True
            End If
        Next
        
        SelectedIndex = Dict.keys
End Property

' リストボックスの選択行数。
Public Function SelectedCount() As Long
    SelectedCount = UBound(SelectedIndex) + 1
End Function

' リスト内で選択された行の値を配列で取得する。
Public Function SelectedValues() As Variant
    
    ' データ格納用配列。
    Dim arr() As Variant
        
        ' 選択行数が０ならば、空配列を返す。
        If SelectedCount = 0 Then
            arr = Array()
        Else
            
            ' 選択行数が１以上の場合、リストの元となった配列の次元数で
            ' 戻り値となる配列の次元数を変える。
            Dim Counter As Long: Counter = 0
            Select Case DimensionNumber
            
                ' リスト用配列が一次元配列の場合、各行の値は一つしかないため、
                ' 一次元配列に格納する。
                Case 1
                    ReDim arr(SelectedCount - 1)
                        For i = 0 To TargetListBox.ListCount - 1
                            If TargetListBox.Selected(i) Then
                                arr(Counter) = TargetListBox.List(i)
                            End If
                        Next
                ' 二次元配列の場合。
                Case 2
                    ReDim arr(SelectedCount - 1, UBound(LatestListArray, 2))
                        For i = 0 To TargetListBox.ListCount - 1
                            If TargetListBox.Selected(i) Then
                                For j = 0 To UBound(arr, 2)
                                    arr(Counter, j) = TargetListBox.List(i, j)
                                Next
                                Counter = Counter + 1
                            End If
                        Next
            End Select
        End If
        
        SelectedValues = arr
End Function

' リストボックス内の全行を選択。
Public Sub SelectAll()
    For i = 0 To TargetListBox.ListCount - 1
        TargetListBox.Selected(i) = True
    Next
End Sub

' リストボックス内の全行を非選択。
Public Sub UnselectAll()
    For i = 0 To TargetListBox.ListCount - 1
        TargetListBox.Selected(i) = False
    Next
End Sub

' リストボックス内の全行について、選択状態を反転。
Public Sub ReverseSelection()
    For i = 0 To TargetListBox.ListCount - 1
        TargetListBox.Selected(i) = Not TargetListBox.Selected(i)
    Next
End Sub

' リストボックス内にある検索値が含まれる行について、
' そのインデックスを配列で返す。
Public Function FindAll(faWhat As Variant, _
               Optional target_column As Long = -1, _
               Optional faLookAt As Excel.XlLookAt = xlPart, _
               Optional faMatchCase As Boolean = False, _
               Optional faMatchByte As Boolean = False) As Variant
     
    ' インデックス格納用辞書。
    ' 後ほどキー情報をまとめて配列として渡せること、要素数に応じた
    ' 拡張が自動で行われることを理由に、辞書を用いている。
    Dim Dict As Object
    Set Dict = CreateObject("Scripting.Dictionary")
    
    ' 検索値は単一であっても、配列で複数渡されても対応可能とする。
    Dim WhatArray As Variant
        If IsArray(faWhat) Then
            WhatArray = faWhat
        Else
            WhatArray = Array(faWhat)
        End If
        
    Dim LoopIndex As Variant
    Dim Temp As String
    
        ' 各検索値に対し、繰り返し処理を行う。
        For Each LoopIndex In WhatArray
        
            ' 大文字・小文字不問であるならば、検索値を全て大文字にしておく。
            If Not faMatchCase Then
                LoopIndex = StrConv(LoopIndex, vbUpperCase)
            End If
            
            ' 半角・全角不問であるならば、検索値を全て全角にしておく。
            If Not faMatchByte Then
                LoopIndex = StrConv(LoopIndex, vbWide)
            End If
            
            ' 部分一致であるならば、検索値の前後にワイルドカードを付しておく。
            If faLookAt = xlPart Then
                LoopIndex = "*" & LoopIndex & "*"
            End If
        
            For j = 0 To UBound(LatestListArray, 2)
                
                ' 列数指定が－１、つまり未指定であるならば、リストボックス全体を
                ' 検索対象とする。
                If target_column = -1 Or target_column = j Then
                    For i = 0 To UBound(LatestListArray)
                        Temp = LatestListArray(i, j)
                        
                        ' 大文字・小文字に対する前処理。
                        If Not faMatchCase Then
                            Temp = StrConv(Temp, vbUpperCase)
                        End If
                        
                        ' 半角・全角に対する前処理。
                        If Not faMatchByte Then
                            Temp = StrConv(Temp, vbWide)
                        End If
                        
                        ' 部分一致対応のため、Like演算子で比較。
                        ' 辞書のItem情報は使用しないため不問。今回は一致したという
                        ' 意味を込めて「True」としている（実際は、何でもよい）。
                        If Temp Like LoopIndex Then
                            Dict(i) = True
                        End If
                    Next
                End If
            Next
        Next
        
        ' キー情報（つまりインデックス情報）を戻り値とする。
        FindAll = Dict.keys
        
        ' 戻り値としての配列を昇順ソート。
        FindAll = SortArray(FindAll)
        
End Function

' リストボックス内にある検索値が含まれる行について、
' その全てを選択する。
Public Sub FindAndSelectAll(faWhat As Variant, _
                   Optional target_column As Long = -1, _
                   Optional faLookAt As Excel.XlLookAt = xlPart, _
                   Optional faMatchCase As Boolean = False, _
                   Optional faMatchByte As Boolean = False)
    
    ' 検索値を含まない行が選択されたままとならないよう、全行の選択状態を
    ' 解除しておく。
    Call UnselectAll
    
    ' 検索値を含む行のインデックスを配列で受け取る。
    Dim arr As Variant
        arr = FindAll(faWhat, target_column, faLookAt, faMatchCase, faMatchByte)
        
        TargetListBox.MultiSelect = fmMultiSelectMulti
    
    ' 受け取ったインデックスの行をすべて選択する。
    Dim LoopIndex As Variant
        For Each LoopIndex In arr
            TargetListBox.Selected(LoopIndex) = True
        Next

End Sub

' リストボックス内にある検索値が含まれる行のみで
' リストボックスを更新する。
Public Sub FindAndUpdateList(faWhat As Variant, _
                   Optional target_column As Long = -1, _
                   Optional faLookAt As Excel.XlLookAt = xlPart, _
                   Optional faMatchCase As Boolean = False, _
                   Optional faMatchByte As Boolean = False)
    
    ' 検索値を含む行のインデックスを配列で受け取る。
    Dim arr As Variant
        arr = FindAll(faWhat, target_column, faLookAt, faMatchCase, faMatchByte)
            
    ' 検索値のみのリスト仮受け。
    Dim Temp() As Variant
    ReDim Temp(UBound(arr), UBound(SourceListArray, 2))
    Dim LoopIndex As Variant
        i = 0
        For Each LoopIndex In arr
            For j = 0 To UBound(Temp, 2)
                Temp(i, j) = LatestListArray(LoopIndex, j)
            Next
            i = i + 1
        Next
        
        LatestListArray = Temp
    Call UpdateList(LatestListArray)

End Sub

' 一次元配列のソート。
Private Function SortArray(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")
    
    Dim LoopIndex As Variant
        For Each LoopIndex In arr
            Call aryList.Add(LoopIndex)
        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

ユーザーフォーム

先日の「りんごとばなな」ボタンについて、りんごとばななを含む行のみで
リストボックスを更新してみた。

Private Sub SelectButton_Click()
    Dim arr As Variant
        arr = Array("りんご", "ばなな")
        
        Lbc.FindAndUpdateList arr
End Sub

結果がこちら。

今のところ、動きは想定どおり。

次回に続きます。

参考まで。