Question

我一直在使用以下代码在Excel中执行粗略查找。该代码可让您查找查找值与字符串表之间的近似匹配。例如，它可以匹配＆＃34; JS Smith＆＃34;约翰·史密斯＆＃34;，＆＃34;第五街西＆＃34;到＆＃34;第五街西＆＃34;等。代码如下：

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

一般情况下效果很好。这段代码的问题似乎总是返回它在表中找到的第一个值，而不是最接近的匹配。我怀疑它可以通过循环遍历表来改进，但我似乎无法使语法工作。我还想为匹配设置一个最小字符串值，如果匹配不是enoguh则为空。

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

Answer 1

这很有意思。也许您可以从函数返回一个数组并将其放入一个下拉框中供用户选择。在您的范围内尝试此列表，并尝试下面的测试人员。

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

Excel中的查找功能返回第一个结果而不是最近匹配

1 个答案: