Excel 中的查找函数返回第一个结果而不是最接近的匹配项

Question

我一直在使用以下代码在 Excel 中执行粗略查找。该代码可让您找到查找值和 table 字符串之间的近似匹配。比如可以将"JS Smith"匹配到"John JS Smith"，"Fifth Street West"匹配到“5th Street West”等，代码如下：

Function FuzzyFind(lookup_value As String, tbl_array As Range) As String
Dim i As Integer, str As String, Value As String
Dim a As Integer, b As Integer, cell As Variant
For Each cell In tbl_array
  str = cell
  For i = 1 To Len(lookup_value)
    If InStr(cell, Mid(lookup_value, i, 1)) > 0 Then
      a = a + 1
      cell = Mid(cell, 1, InStr(cell, Mid(lookup_value, i, 1)) - 1) & Mid(cell, InStr(cell, Mid(lookup_value, i, 1)) + 1, 9999)
    End If
  Next i
  a = a - Len(cell)
  If a > b Then
    b = a
    Value = str
  End If
  a = 0
Next cell
FuzzyFind = Value
End Function

总的来说效果很好。此代码的问题在于它似乎总是 return 它在 table 中找到的第一个值，而不是最接近的匹配项。我怀疑可以通过让它循环 table 来改进它，但我似乎无法使语法工作。我还想为匹配项输入一个最小字符串值，以便在匹配项不接近时它为空。

如何更改此代码，使其 return 成为最接近的结果而不是第一个，并输入最小值以使其不会 return 不准确匹配？

Answer 1

这很有趣。也许您可以 return 函数中的一个数组并将其放入下拉框中供用户选择。在您的范围内尝试此列表并尝试下面的测试器子。

Function FuzzyFind(lookup_value As String, tbl_array As Range) As Variant

Dim i As Integer, str As String,
Dim a As Integer, b As Integer, x as integer
Dim callingStringArray, matchArray() As Variant
Dim myArray() As Variant, arrayCounter As Long    

    Do While InStr(1, lookup_value, "  ")
        lookup_value = Replace(lookup_value, "  ", " ")
    Loop
    lookup_value = Trim(lookup_value)

    callingStringArray = Split(lookup_value)
    ReDim matchArray(1 To 1)
    arrayCounter = 1
    a = 0
    b = 1
    X = 2

'   For exact match it woulkd return only this string
If UBound(callingStringArray) > 1 Then
    With tbl_array
        Set c = .Find(callingStringArray(a) & " " & callingStringArray(b), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ReDim Preserve matchArray(1 To arrayCounter)
                    matchArray(arrayCounter) = c
                    arrayCounter = arrayCounter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
    End With

    With tbl_array
    tempVar = (callingStringArray(b) & " " & callingStringArray(X))
        Set c = .Find((tempVar), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ReDim Preserve matchArray(1 To arrayCounter)
                    matchArray(arrayCounter) = c
                    arrayCounter = arrayCounter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
    End With

    With tbl_array
        Set c = .Find(callingStringArray(b) & " " & callingStringArray(a), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ReDim Preserve matchArray(1 To arrayCounter)
                    matchArray(arrayCounter) = c
                    arrayCounter = arrayCounter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
    End With

    With tbl_array
        Set c = .Find(callingStringArray(a) & " " & callingStringArray(X), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ReDim Preserve matchArray(1 To arrayCounter)
                    matchArray(arrayCounter) = c
                    arrayCounter = arrayCounter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
    End With

    With tbl_array
        Set c = .Find(callingStringArray(X) & " " & callingStringArray(a), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ReDim Preserve matchArray(1 To arrayCounter)
                    matchArray(arrayCounter) = c
                    arrayCounter = arrayCounter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
    End With
    With tbl_array
        Set c = .Find(callingStringArray(X) & " " & callingStringArray(b), LookIn:=xlValues, LookAt:=xlPart, MatchCase:=False)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ReDim Preserve matchArray(1 To arrayCounter)
                    matchArray(arrayCounter) = c
                    arrayCounter = arrayCounter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
    End With

Else

    For i = LBound(callingStringArray) To UBound(callingStringArray)
        With tbl_array
            Set c = .Find(callingStringArray(i), LookIn:=xlValues, LookAt:=xlPart)
            If Not c Is Nothing Then
                firstAddress = c.Address
                Do
                    ReDim Preserve matchArray(1 To arrayCounter)
                    matchArray(arrayCounter) = c
                    arrayCounter = arrayCounter + 1
                    Set c = .FindNext(c)
                Loop While Not c Is Nothing And c.Address <> firstAddress
            End If
        End With
    Next i


End If




FuzzyFind = matchArray()
End Function



Sub testere4sed()
Dim anotherArray As Variant

    anotherArray = FuzzyFind("Fifth Cat St.", Range("A1:A70"))
    For i = LBound(anotherArray) To UBound(anotherArray)
        Debug.Print anotherArray(i)
    Next I

    Debug.Print "***********************"

    anotherArray = FuzzyFind("    Cat  ", Range("A1:A70"))
    For i = LBound(anotherArray) To UBound(anotherArray)
       Debug.Print anotherArray(i)
    Next I

End Sub