ListBoxを操作するクラスモジュール　⑨ レーベンシュタイン距離（２）

ListBoxを操作するクラスモジュールを、私なりに作成中。
前回は、レーベンシュタイン距離を用いて、「探している文字と何か似てる」ものを探すことに挑戦した。
infoment.hatenablog.com

今日も、昨日の続きから。
f:id:Infoment:20201012232325p:plain

昨日の一致率リスト表示には、以下の問題があった。

一致率でソートされていない。
毎回シートに貼り付けて結果を確認。

これでは、とても面倒くさくてやってられない。しかし、二次元配列のソートは、これはこれで難解だ（できないことはないが）。

そこで今回は割り切って、シートに貼り付けてソートすることにした。
作戦はこうだ。

ソート用シートを追加する。
そこに一致率を求めた配列を張り付けて、一致率で降順ソート。
クラスモジュールを破棄する際に、ソート用シートも削除する。

クラスモジュール（ListBoxControl）

Private Sh(1) As Worksheet

' 一致率を収めた配列。
Public Function MatchRatioAll(mrWhat As Variant, _
                     Optional target_column As Long = -1) As Variant
    Dim arr() As Variant
    ReDim arr(1 To (UBound(LatestListArray) + 1) * (UBound(LatestListArray, 2) + 1) + 1, _
              1 To 5)
              
        arr(1, 1) = "行番号"
        arr(1, 2) = "列番号"
        arr(1, 3) = "指定文字"
        arr(1, 4) = "比較文字"
        arr(1, 5) = "一致率％"

    Dim Temp As String
    Dim Counter As Long: Counter = 2

        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)
                    arr(Counter, 1) = i
                    arr(Counter, 2) = j
                    arr(Counter, 3) = mrWhat
                    arr(Counter, 4) = Temp
                    arr(Counter, 5) = Format(MatchRatio(CStr(mrWhat), Temp) * 100, "0.0")
                    Counter = Counter + 1
                Next
            End If
        Next
        
        ' 今回、ソートを追加。
        MatchRatioAll = Sort2DArray(arr, xlYes, 5, xlDescending)
              
End Function

' 二次元配列のソート。
Public Function Sort2DArray(source_array As Variant, _
                   Optional header As XlYesNoGuess = xlYes, _
                   Optional target_column_index As Long = 1, _
                   Optional sort_order As Excel.XlSortOrder = xlAscending) As Variant
                   
    Set Sh(0) = ActiveSheet
        If Sh(1) Is Nothing Then
            Set Sh(1) = Sheets.Add
            Sh(0).Activate
        End If
        Sh(1).Cells.Clear
        Sh(1).Range("A1").Resize(UBound(source_array), UBound(source_array, 2)) = source_array

    Dim Tb As ListObject
    Set Tb = Sh(1).ListObjects.Add(xlSrcRange, Sh(1).UsedRange, , header)
    
        Tb.Sort.SortFields.Clear
        Tb.Sort.SortFields.Add Key:=Cells(1, target_column_index), _
                           Order:=sort_order

        With Tb.Sort
            .header = header
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With

        Sort2DArray = Tb.Range

End Function

' ソート用シートを破棄。
Private Sub Class_Terminate()
    
    On Error Resume Next
    If Application.ScreenUpdating = True Then Application.ScreenUpdating = False
    Select Case Application.DisplayAlerts
        Case True
            Application.DisplayAlerts = False
            Sh(1).Delete
            Application.DisplayAlerts = True
        Case Else
            Sh(1).Delete
    End Select
    Application.ScreenUpdating = True
End Sub

ユーザーフォーム

こちらには、一致率を表示するリストボックスを追加した。
f:id:Infoment:20201012233026p:plain

Option Explicit

Dim Lbc(1 To 2) As VBAProject.ListBoxControl

' ユーザーフォームの初期化。
Private Sub UserForm_Initialize()

    ' リストボックスに表示する範囲を、一旦配列に格納。
    Dim arr As Variant
        arr = ActiveSheet.UsedRange
    
    ' クラスモジュールの初期化。
    Dim i As Long
        For i = 1 To 2
            Set Lbc(i) = New VBAProject.ListBoxControl
            Set Lbc(i).TargetListBox = Me.Controls("ListBox" & i)
        Next
        
        ' リストの内容として配列をセット。
        Lbc(1).InitializeList arr, True, True
End Sub

' 正規表現を利用した絞り込み。
Private Sub TextBox1_Change()
    Lbc(1).ResetList
    If TextBox1.Value <> vbNullString Then
        Lbc(1).RegExpAndUpdateList TextBox1.Value
    End If
End Sub

' 一致率表示。
Private Sub CommandButton1_Click()
    Dim arr As Variant
        arr = Lbc(1).MatchRatioAll(TextBox2.Value, 1)
        Lbc(2).InitializeList arr, True, True
End Sub