【VBA】一致率の可視化（レーベンシュタイン距離）続

以前、Excelでレーベンシュタイン距離を見えるようにした記事を投稿しました。

書いた当時は、こんな記事はほとんど見られないだろうと思っていたのですが、
意外や意外、このサイト内でトップ３に入る注目記事となっています。

そこで、今度はこの手順をワークシートの関数ではなく、VBAで実装してみました。

Rosetta Codeをのぞいてみる

レーベンシュタイン距離は二重ループを回すのが基本だと思いますが、
ここは少し手を抜いて、Rosetta Codeの実装例を見てみます。

やはり、二重ループですね。

というわけでこれを魔改造してみましょう。

Option Explicit
Option Base 1
Public Sub levenshtein(s1 As String, s2 As String)
    Dim n As Integer: n = Len(s1) + 1
    Dim m As Integer: m = Len(s2) + 1
    
' ### 追加部分 ###
'長い方の文字数を取得するのと、文字列を一文字ずつ格納した配列を用意する
'文字の配列は一括で代入するため、二次元配列にしておく
    Dim lr As Integer
    If n >= m Then
        lr = n
    Else
        lr = m
    End If
    
    Dim s1s() As String, s2s() As String
    ReDim s1s(n, 1)
    ReDim s2s(1, m)
' ### 追加ここまで ###
    
    Dim d() As Integer, i As Integer, j As Integer
    ReDim d(n, m)
 
    If n = 1 Or m = 1 Then
        Exit Sub
    End If
 
    For i = 1 To n
        d(i, 1) = i - 1
        ' ### 追加部分 ###
        '文字列を1文字ずつ入れておく
        s1s(i, 1) = Mid(s1, i, 1)
　　　　' ### 追加ここまで ###
    Next i
 
    For j = 1 To m
        d(1, j) = j - 1
        ' ### 追加部分 ###
        '文字列を1文字ずつ入れておく
        s2s(1, j) = Mid(s2, j, 1)
　　　　' ### 追加ここまで ###
    Next j
 
    For i = 2 To n
        For j = 2 To m
            d(i, j) = WorksheetFunction.Min( _
                           d(i - 1, j) + 1, _
                           d(i, j - 1) + 1, _
                           (d(i - 1, j - 1) - (Mid(s1, i - 1, 1) <> Mid(s2, j - 1, 1))) _
                           )
        Next j
    Next i
 
    ' ### 追加部分 ###
    ' ワークシートに書き出しをする
    With ThisWorkbook.Sheets(1)
        .Range("A5").Value = "結果"
        .Range("B5").Value = "'" & d(n, m) & " ／ " & lr
        .Range("C5").Value = 1 - d(n, m) / (lr - 1)
        .Range("A8").Resize(n, 1) = s1s
        .Range("C6").Resize(1, m) = s2s
        .Range("B7").Resize(i - 1, j - 1) = d
        .Range("A5").Select
    End With
　　' ### 追加ここまで ### 
End Sub

' ### 呼び出し用の関数を変更
Public Sub main()
' ### 古いデータを削除
    Call clear_old
' ### ワークシート上のデータを利用
    With ThisWorkbook.Sheets(1)
        Call levenshtein(.Range("B2").Text, .Range("B3").Text)
    End With
End Sub

Private Sub clear_old()
    With ThisWorkbook.Sheets(1)
        .Range("A5").Select
        Range(Selection, ActiveCell.SpecialCells(xlLastCell)).Select
        Selection.ClearContents
    End With
End Sub

これで改造は完了です。