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

我一直在使用下面的代码在Excel中执行粗略的查找。 该代码可以让你find一个查找值和一个string表之间的大致匹配。 例如，可以将“JS史密斯”与“约翰·JS·史密斯”，“第五街西”，“第五街西”等相匹配。代码如下：

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 

一般来说，它工作得很好。 这个代码的问题似乎总是返回它在表中find的第一个值，而不是最接近的匹配。 我怀疑它可以通过让它循环遍历表，但我似乎无法使语法的工作。 我也想在一个匹配的最小string值，以便它是空白的，如果匹配不是closuresenoguh。

我怎样才能改变这个代码，使其返回最接近的结果，而不是第一个，并input一个最小值，以便它不会返回不准确的匹配？

Answer 1

那很有意思。 也许你可以从函数返回一个数组，并把它放到一个下拉框供用户select。 尝试在你的范围这个清单，并尝试下面的testing仪子。

 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