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

ListBoxを操作するクラスモジュールを、私なりに作成中。
前回は、正規表現によるマッチング結果で、リストボックスの
表示内容を絞り込んでみた。
infoment.hatenablog.com

今日も、前回の続きから。
f:id:Infoment:20201011112438p:plain

前回までに、リスト項目の絞り込みについて、

キーワードによる部分一致／完全一致
正規表現によるパターンマッチング

を盛り込んでみた。

そこで今回は、このブログでも何度か紹介した「レーベンシュタイン距離」を
用いた「一致率」で、リストボックスの表示内容を絞り込むことに挑戦する。

クラスモジュール（ListBoxControl）

レーベンシュタイン距離はいつものように、こちらを参考にした。
（ありがとうございます）。
code.i-harness.com

ここでの一致率は、以下のように定義した。

一致率＝｛検索文字数－レーベンシュタイン距離（検索文字，比較文字）｝／検索文字数

ひょっとしたら、本来の定義とは違うかもしれない（ご容赦ください）。

' 参照元。
' URL ⇒　https://code.i-harness.com/ja-jp/q/40be5c
Public Function Levenshtein(ByVal string1 As String, ByVal string2 As String) As Long

    Dim i As Long
    Dim j As Long
    Dim string1_length As Long
        string1_length = Len(string1)
    Dim string2_length As Long
        string2_length = Len(string2)
    Dim distance() As Long
    ReDim distance(string1_length, string2_length)
    
        For i = 0 To string1_length
            distance(i, 0) = i
        Next
        
        For j = 0 To string2_length
            distance(0, j) = j
        Next
    
        For i = 1 To string1_length
            For j = 1 To string2_length
                If Asc(Mid$(string1, i, 1)) = Asc(Mid$(string2, j, 1)) Then
                    distance(i, j) = distance(i - 1, j - 1)
                Else
                    distance(i, j) = Application.WorksheetFunction.Min _
                    (distance(i - 1, j) + 1, _
                     distance(i, j - 1) + 1, _
                     distance(i - 1, j - 1) + 1)
                End If
            Next
        Next
    
        Levenshtein = distance(string1_length, string2_length)

End Function

' 一致率。
Public Function MatchRatio(ByVal string1 As String, ByVal string2 As String) As Double

    Dim ⊿ As Long
        ⊿ = Levenshtein(string1, string2)
        
        MatchRatio = (Len(string1) - ⊿) / Len(string1)

End Function

' 一致率を収めた配列。
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 = arr
              
End Function

ユーザーフォーム

先日の「正規表現による絞り込み用テキストボックス」の横に、一致率による絞り込み用テキストボックス（TextBox2）を追加した。
f:id:Infoment:20201011113527p:plain

「一致率で探す」ボタンを押した結果を、Sheet2に書き出してみよう。

Private Sub CommandButton1_Click()
    Dim arr As Variant
        arr = Lbc.MatchRatioAll(TextBox2.Value, 1)
        Sheet2.Range("A1").Resize(UBound(arr), UBound(arr, 2)) = arr
End Sub