Question

我现有的代码在单元格C3中获取用户输入时工作正常，搜索下面的数据表，并在前几行中整齐地显示产品代码的所有匹配结果。我需要更新此代码，以便在找不到完全匹配的情况下获得一些逻辑，但可能找到了类似的匹配。这是现有的代码：

    Option Compare Text
    Sub MultipleLkp()

    Dim numRows As Integer, numCols As Integer, i As Integer, j As Integer, k As Integer, PrimKey, lastColumn As Long
    Dim Trimkey As String


    Application.ScreenUpdating = False
    Worksheets("DashboardMain").Range("D3:R8").ClearContents
    Worksheets("DashboardMain").Range("C200").CurrentRegion.Select
    PrimKey = Worksheets("DashboardMain").Range("C3").Value
    numRows = Selection.Rows.Count
    numCols = Selection.Columns.Count
    j = 2
    lastColumn = Cells.Find(What:="*", After:=Range("A1"), Lookat:=xlPart, LookIn:=xlFormulas, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False).Column

    'TrimKey is the variable replacing PrimKey but without spaces or hyphens.
    'allows user to input a model with or without " " or "-" in cell C3
    'can be modified to include more invalid characters
    Trimkey = Replace(Replace(PrimKey, " ", ""), "-", "")
    If Trimkey = "" Then
    Exit Sub
    End If
    'runs the loop and returns all matches; displays matches in rows 3 down until all matches found
    'does not have any logic if no match is found. need to add the "like" function?
    For i = 2 To numRows
        If Worksheets("DashboardMain").Cells(199 + i, 3).Value = Trimkey Then
            j = j + 1
            For k = 1 To lastColumn
                Worksheets("DashboardMain").Cells(j, 3 + k).Value = Worksheets("DashboardMain").Cells(199 + i, 3 + k).Value
            Next k
        End If
    Next I
end sub

理想情况下，如果找不到完全匹配，将显示一个消息框，显示可能的匹配，然后用户可以选择潜在匹配，然后根据相同的区域显示，就好像它是完全匹配一样。任何帮助表示赞赏

Answer 1

好吧，在我的特殊Excel插件中，我有一些特殊的功能。

Public Function LEVEN(s1 As String, s2 As String) As Integer
    If Len(s1) > Len(s2) Then
        LEVEN = Levenshtein(s1, s2)
    Else
        LEVEN = Levenshtein(s2, s1)
    End If

End Function

Private Function Levenshtein(s1 As String, s2 As String) As Integer

Dim i As Integer
Dim j As Integer
Dim l1 As Integer
Dim l2 As Integer
Dim d() As Integer
Dim min1 As Integer
Dim min2 As Integer

l1 = Len(s1)
l2 = Len(s2)
ReDim d(l1, l2)
For i = 0 To l1
    d(i, 0) = i
Next
For j = 0 To l2
    d(0, j) = j
Next
For i = 1 To l1
    For j = 1 To l2
        If Mid(s1, i, 1) = Mid(s2, j, 1) Then
            d(i, j) = d(i - 1, j - 1)
        Else
            min1 = d(i - 1, j) + 1
            min2 = d(i, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            min2 = d(i - 1, j - 1) + 1
            If min2 < min1 Then
                min1 = min2
            End If
            d(i, j) = min1
        End If
    Next
Next
Levenshtein = d(l1, l2)
End Function

LEVEN以Levenshtein的算法为基础，衡量一个文本转换为另一个文本必须进行多次更改（删除，替换）。此功能测量两个字符串之间的距离。所以，你可以添加像boolExact这样的布尔变量，如果

，它将变为TRUE

 If Worksheets("DashboardMain").Cells(199 + i, 3).Value = Trimkey Then

实现了。然后，设置条件指令检查，如果不是boolExact，如果是，运行将检查的子程序

if LEVEN( Worksheets("DashboardMain").Cells(199 + i, 3).Value, TrimKey)>3

这是直截了当的解决方案。注意，两个字母的单词最多相距两步，因此LEVEN将返回2.您可能会发现有用的比较LEVEN（x，y）/ max（LEN（x），LEN（y））来测量相对距离。

for循环返回完全匹配但需要更新以返回类似的匹配

1 个答案: