見た目が似た文字列を検索するVLOOKUP的なExcelの関数をレーベンシュタイン距離を使って作る。

やりたいこと

文字列の類似度合によって、あたえた表の中で一番似てる字面のセルに寄せるVLOOKUP的な関数を作りたい。

たとえば、下記の表でA7～B12に記載の食品名を A2～A4に記載の「チュロス」「ジュース」「丼」に寄せたい。
たとえば、チュリトスは、もっとも字づらが似ている「チュロス」として認識したい。
その際に、類似度としてレーベンシュタイン距離(Levenshtein-Distance)を使う。
よって、この関数の名前をVLOOKUPLDと名付ける。

引数は、VLOOKUPに倣って、検索値、範囲、列番号にします。
B7には、=VLOOKUPLD(A7,\$A\$2:\$A\$4,1)
C7には、=VLOOKUPLD(A7,\$A\$2:\$A\$4,2) と入っています。

対象の読者

Excel VBAの標準モジュールにてユーザー定義関数の作り方をご存じの方

まずはレーベンシュタイン距離の実装

VLOOKUPLD関数を作るまえに、類似度を測定するレーベンシュタイン距離を求める関数を実装します。
Wikipediaのhttps://ja.wikipedia.org/wiki/レーベンシュタイン距離に記載の疑似コードを愚直にVBAに移植しました。 (ただし、VBSでも使えるように As Long などの型宣言は省いていますし、配列の宣言における 0 To と下限宣言も省いています。)

このようになります。　これを標準モジュールに実装します。

Function LevenshteinDistance(str1, str2)
'https://ja.wikipedia.org/wiki/レーベンシュタイン距離の疑似コードより移植
'vbsでも使えるように型はすべて宣言せずバリアント型
    Dim d()
    Dim lenStr1
    Dim lenStr2
    Dim i1
    Dim l2
    Dim cost
    Dim del
    Dim ins
    Dim rep

    lenStr1 = Len(str1)
    lenStr2 = Len(str2)

    ReDim d(lenStr1, lenStr2)
    For i1 = 0 To lenStr1
        d(i1, 0) = i1
    Next

    For i2 = 0 To lenStr2
        d(0, i2) = i2
    Next

    For i1 = 1 To lenStr1
        For i2 = 1 To lenStr2
           If Mid(str1, i1, 1) = Mid(str2, i2, 1) Then
                cost = 0
           Else
                cost = 1
           End If
           del = d(i1 - 1, i2) + 1   '文字の削除
           ins = d(i1, i2 - 1) + 1   '文字の挿入
           rep = d(i1 - 1, i2 - 1) + cost '文字の置換
           min = del
           If min > ins Then
                min = ins
           End If
           If min > rep Then
                min = rep
           End If
           d(i1, i2) = min
        Next
    Next
    LevenshteinDistance = d(lenStr1, lenStr2)
End Function

VLOOKUPLD関数の実装

レーベンシュタイン距離を求める関数ができたので、次にVLOOKUPLD関数を作ります。

あたえられた値（またはセル参照）とあたえられたセル範囲の各セルとのレーベンシュタイン距離を求め、レーベンシュタイン距離が最小となるセルの 指定された列番号-1ぶん右にずれたセルを返します。

こちらの関数は、Excelから使うことしか考えないので、できるかぎり、型宣言をします。
第1引数についてはエラー処理は特にせず、エラーが発生したら、#Valueになるに任せます。

'レーベンシュタイン距離による判定でもっとも近い内容のセルに無理やり寄せる関数
Function VLOOKUPLD(lookup_value, table_array, col_index_num)
    Dim r As Range
    Dim str1 As String
    Dim str2 As String
    Dim min As Long '最小の類似度
    Dim ld As Long '類似度(レーベンシュタイン距離)

    Dim matchedRange As Range '暫定の最小類似度のセル(解答となるセル)

    'セルが#Valueのときはstr1への代入はエラーになります。このときは、エラー処理しません。
    str1 = lookup_value
    For Each r In table_array
        On Error Resume Next
        str2 = r    'セルが#Valueのときはエラーになります。このときはそのセルを無視します。
        If Err Then
        Else
            ld = LevenshteinDistance(str1, str2)
            'いままでのセルよりもさらに類似してるか、最初の比較であれば、比較セルを
            '暫定の解答セルとして認識します。
            If (ld < min) Or (matchedRange Is Nothing) Then
                Set matchedRange = r
                min = ld
            End If
        End If
        On Error GoTo 0
    Next
    'matchedRangeがNothingの場合、エラーとなりますが、特にエラー処理せず
    '#Valueになることにまかせます。
    '解答となるセルの指定列-1ぶん右にずれたセルの値を返します。
    VLOOKUPLD = matchedRange.Offset(0, col_index_num - 1)
End Function

おことわり

判定結果は機械的なアルゴリズムによる類似度によるものですので、文字列の長さなどの諸条件により、人間の目でみてまったく類似性がないものにマッチする場合がありますので、参考結果程度に受け取ってください。

ライセンス的なこと

本コードによる結果については、いかなる責任も負いません。
自由に改変して使って頂いたり、世間に発表して頂いて、結構です。
もし可能なら、発表時に謝辞をいただけると幸いです。

２つをまとめたコード

コピペしやすいように、２つをまとめたコードもここに記載します。
ソースの黒枠の右上にカーソルをもっていくと、コピー用アイコンがでるので、便利です。

Function LevenshteinDistance(str1, str2)
'https://ja.wikipedia.org/wiki/レーベンシュタイン距離の疑似コードより移植
'vbsでも使えるように型はすべて宣言せずバリアント型
    Dim d()
    Dim lenStr1
    Dim lenStr2
    Dim i1
    Dim l2
    Dim cost
    Dim del
    Dim ins
    Dim rep

    lenStr1 = Len(str1)
    lenStr2 = Len(str2)

    ReDim d(lenStr1, lenStr2)
    For i1 = 0 To lenStr1
        d(i1, 0) = i1
    Next

    For i2 = 0 To lenStr2
        d(0, i2) = i2
    Next

    For i1 = 1 To lenStr1
        For i2 = 1 To lenStr2
           If Mid(str1, i1, 1) = Mid(str2, i2, 1) Then
                cost = 0
           Else
                cost = 1
           End If
           del = d(i1 - 1, i2) + 1   '文字の削除
           ins = d(i1, i2 - 1) + 1   '文字の挿入
           rep = d(i1 - 1, i2 - 1) + cost '文字の置換
           min = del
           If min > ins Then
                min = ins
           End If
           If min > rep Then
                min = rep
           End If
           d(i1, i2) = min
        Next
    Next
    LevenshteinDistance = d(lenStr1, lenStr2)
End Function

'レーベンシュタイン距離による判定でもっとも近い内容のセルに無理やり寄せる関数
Function VLOOKUPLD(lookup_value, table_array, col_index_num)
    Dim r As Range
    Dim str1 As String
    Dim str2 As String
    Dim min As Long '最小の類似度
    Dim ld As Long '類似度(レーベンシュタイン距離)

    Dim matchedRange As Range '暫定の最小類似度のセル(解答となるセル)

    'セルが#Valueのときはstr1への代入はエラーになります。このときは、エラー処理しません。
    str1 = lookup_value
    For Each r In table_array
        On Error Resume Next
        str2 = r    'セルが#Valueのときはエラーになります。このときはそのセルを無視します。
        If Err Then
        Else
            ld = LevenshteinDistance(str1, str2)
            'いままでのセルよりもさらに類似してるか、最初の比較であれば、比較セルを
            '暫定の解答セルとして認識します。
            If (ld < min) Or (matchedRange Is Nothing) Then
                Set matchedRange = r
                min = ld
            End If
        End If
        On Error GoTo 0
    Next
    'matchedRangeがNothingの場合、エラーとなりますが、特にエラー処理せず
    '#Valueになることにまかせます。
    '解答となるセルの指定列-1ぶん右にずれたセルの値を返します。
    VLOOKUPLD = matchedRange.Offset(0, col_index_num - 1)
End Function