Question

我正在为Microsoft Office套件构建私有拼写检查程序。我正在对拼写错误进行字符串比较，以及确定我想要包含哪些更正的潜在修复。

对于加权 Damerau-Levenshtein公式进行字符串比较，我看起来很高和很低，因为我希望交换，插入，删除和替换都具有不同的权重，而不仅仅是“1”的权重“所以我可以优先考虑其他人的一些更正。例如，错字“agmes”在理论上可以纠正为“游戏”或“age”，因为两者都只需要一次编辑就可以移动到拼写正确的单词，但我想给出“交换“编辑较低的权重，以便”游戏“显示为首选更正。

我正在使用Excel进行分析，因此我使用的任何代码都需要在Visual Basic for Applications（VBA）中。我能找到的最好的是this example，看起来很棒，但它是用Java编写的。我尽力转换，但我远非专家，可以使用一点帮助！

任何人都可以查看附加的代码并帮我弄清楚出了什么问题吗？

谢谢！

编辑：我自己开始工作。这是VBA中加权的Damerau-Levenshtein公式。它使用Excel的内置数学函数进行一些评估。将拼写错误与两种可能的更正进行比较时，最高成本的修正是首选字。这是因为两次掉期的成本必须大于删除和插入的成本，如果您分配成本最低的掉期（我认为这是理想的），这是不可能的。如果您需要更多信息，请查看Kevin的博客。

Public Function WeightedDL(source As String, target As String) As Double

    Dim deleteCost As Double
    Dim insertCost As Double
    Dim replaceCost As Double
    Dim swapCost As Double

    deleteCost = 1
    insertCost = 1.1
    replaceCost = 1.1
    swapCost = 1.2

    Dim i As Integer
    Dim j As Integer
    Dim k As Integer

    If Len(source) = 0 Then
        WeightedDL = Len(target) * insertCost
        Exit Function
    End If

    If Len(target) = 0 Then
        WeightedDL = Len(source) * deleteCost
        Exit Function
    End If

    Dim table() As Double
    ReDim table(Len(source), Len(target))

    Dim sourceIndexByCharacter() As Variant
    ReDim sourceIndexByCharacter(0 To 1, 0 To Len(source) - 1) As Variant

    If Left(source, 1) <> Left(target, 1) Then
        table(0, 0) = Application.Min(replaceCost, (deleteCost + insertCost))
    End If

    sourceIndexByCharacter(0, 0) = Left(source, 1)
    sourceIndexByCharacter(1, 0) = 0

    Dim deleteDistance As Double
    Dim insertDistance As Double
    Dim matchDistance As Double

    For i = 1 To Len(source) - 1

        deleteDistance = table(i - 1, 0) + deleteCost
        insertDistance = ((i + 1) * deleteCost) + insertCost

        If Mid(source, i + 1, 1) = Left(target, 1) Then
            matchDistance = (i * deleteCost) + 0
        Else
            matchDistance = (i * deleteCost) + replaceCost
        End If

        table(i, 0) = Application.Min(Application.Min(deleteDistance, insertDistance), matchDistance)
    Next

    For j = 1 To Len(target) - 1

        deleteDistance = table(0, j - 1) + insertCost
        insertDistance = ((j + 1) * insertCost) + deleteCost

        If Left(source, 1) = Mid(target, j + 1, 1) Then
            matchDistance = (j * insertCost) + 0
        Else
            matchDistance = (j * insertCost) + replaceCost
        End If

        table(0, j) = Application.Min(Application.Min(deleteDistance, insertDistance), matchDistance)
    Next

    For i = 1 To Len(source) - 1

        Dim maxSourceLetterMatchIndex As Integer

        If Mid(source, i + 1, 1) = Left(target, 1) Then
            maxSourceLetterMatchIndex = 0
        Else
            maxSourceLetterMatchIndex = -1
        End If

        For j = 1 To Len(target) - 1

            Dim candidateSwapIndex As Integer
            candidateSwapIndex = -1

            For k = 0 To UBound(sourceIndexByCharacter, 2)
                If sourceIndexByCharacter(0, k) = Mid(target, j + 1, 1) Then candidateSwapIndex = sourceIndexByCharacter(1, k)
            Next

            Dim jSwap As Integer
            jSwap = maxSourceLetterMatchIndex

            deleteDistance = table(i - 1, j) + deleteCost
            insertDistance = table(i, j - 1) + insertCost
            matchDistance = table(i - 1, j - 1)

            If Mid(source, i + 1, 1) <> Mid(target, j + 1, 1) Then
                matchDistance = matchDistance + replaceCost
            Else
                maxSourceLetterMatchIndex = j
            End If

            Dim swapDistance As Double

            If candidateSwapIndex <> -1 And jSwap <> -1 Then

                Dim iSwap As Integer
                iSwap = candidateSwapIndex

                Dim preSwapCost
                If iSwap = 0 And jSwap = 0 Then
                    preSwapCost = 0
                Else
                    preSwapCost = table(Application.Max(0, iSwap - 1), Application.Max(0, jSwap - 1))
                End If

                swapDistance = preSwapCost + ((i - iSwap - 1) * deleteCost) + ((j - jSwap - 1) * insertCost) + swapCost

            Else
                swapDistance = 500
            End If

            table(i, j) = Application.Min(Application.Min(Application.Min(deleteDistance, insertDistance), matchDistance), swapDistance)

        Next

        sourceIndexByCharacter(0, i) = Mid(source, i + 1, 1)
        sourceIndexByCharacter(1, i) = i

    Next

    WeightedDL = table(Len(source) - 1, Len(target) - 1)

End Function

Answer 1

我可以看到你自己已经回答了这个问题：几年前我写了一个改进的Levenshtein编辑距离算法用于地址匹配（该网站现在在俄罗斯托管，去那里是一个坏主意）但是没有很好地执行，并且“共同字符串的总和”方法足以完成手头的任务：

Fuzzy-Matching strings in Excel using a simplified 'Edit Distance' proxy in VBA

该代码可能需要重新测试和重新工作。

查看您的代码，如果您想再次访问它，请参阅速度提示：

Dim arrByte() As Byte 
Dim byteChar As Byte 

arrByte = strSource

for i = LBound(arrByte) To UBound(arrByte) Step 2 
    byteChar = arrByte(i)     ' I'll do some comparison operations using integer arithmetic on the char
Next i

即使使用Mid $（）而不是Mid（），VBA中的字符串处理速度也非常慢，但数值运算非常好：字符串实际上是字节数组，编译器将接受面值。

循环中2的'step'是跳过unicode字符串中的高位字节 - 你可能在普通的ASCII文本上运行你的字符串比较，你'将看到（例如）“ABCd”的字节数组是（00,65,00,66,00,67,00,100）。西欧国家的大多数拉丁字母 - 重音符号，变音符号，双音素和全部 - 将适合低于255，并且不会冒险进入在该示例中显示为零的高阶字节。

你会在希伯来语，希腊语，俄语和阿拉伯语的严格单语字符串比较中得到它，因为在每个字母表中高位字节是常数：希腊语“αβγδ”是字节数组（177 ，3,178,3,179,3,180,3）。然而，这是邋coding的编码，当你尝试跨语言进行字符串比较时，它会咬你（或字节）。它永远不会在东方字母表中飞行。

Answer 2

相信这些行错误： -

deleteDistance = table(0, j - 1) + insertCost
insertDistance = ((j + 1) * insertCost) + deleteCost

认为应该是： -

deleteDistance = ((j + 1) * insertCost) + deleteCost
insertDistance = table(0, j - 1) + insertCost

Haven没有通过代码来计算出现的情况，但下面是奇怪的！

If Left(source, 1) <> Left(target, 1) Then
    table(0, 0) = Application.Min(replaceCost, (deleteCost + insertCost))
End If

您需要替换，删除或插入它可能应该是： -

If Left(source, 1) <> Left(target, 1) Then
    table(0, 0) = Application.Min(replaceCost, Application.Min(deleteCost, insertCost))
End If

VBA中的加权Damerau-Levenshtein

2 个答案: