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

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

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

そこで、今度はこの手順をワークシートの関数ではなく、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

これで改造は完了です。

試してみる

次に、ワークシートを作っていきます。

コードにも書いてあるとおり、B2とB3に文字列を記入できるようにしています。

さらにマクロの実行ボタンも追加しておきましょう。

あとは実行ボタンにプロシージャ main を登録するだけです。

前回と同じ文を入力して実行ボタンを押すと……

すぐに結果が表示されます。

実用化の予定

一文同士の比較であれば、VBAでのレーベンシュタイン距離の計算もいけそうですね。

この用途としては、微妙な修正テキストやチェック前/後の比較などを検討中です。

それには getOcode のような、何文字目がどう違うのかを求めるプログラムが必要になりそうですが……

次はこの部分についても実装していきたいと思います。

CATOVIS LS

MS Office Wordと接続。軽量型でWYSIWYGを実現