相似度列中显示的百分比仅为说明性质。我认为相似性测试可能是以下内容之一：以下是使用VBA UDF的解决方案：
编辑: 添加了一个名为arg_lMinConsecutive的新可选参数，用于确定必须匹配的最小连续字符数。请注意下面公式中的额外参数2，表示至少必须有2个连续字符匹配。
Public Function FuzzyMatch(ByVal arg_sText As String, _
ByVal arg_vList As Variant, _
ByVal arg_lOutput As Long, _
Optional ByVal arg_lMinConsecutive As Long = 1, _
Optional ByVal arg_bMatchCase As Boolean = True, _
Optional ByVal arg_bExactCount As Boolean = True) _
As Variant
Dim dExactCounts As Object
Dim aResults() As Variant
Dim vList As Variant
Dim vListItem As Variant
Dim sLetter As String
Dim dMaxMatch As Double
Dim lMaxIndex As Long
Dim lResultIndex As Long
Dim lLastMatch As Long
Dim i As Long
Dim bMatch As Boolean
If arg_lMinConsecutive <= 0 Then
FuzzyMatch = CVErr(xlErrNum)
Exit Function
End If
If arg_bExactCount = True Then Set dExactCounts = CreateObject("Scripting.Dictionary")
If TypeName(arg_vList) = "Collection" Or TypeName(arg_vList) = "Range" Then
ReDim aResults(1 To arg_vList.Count, 1 To 3)
Set vList = arg_vList
ElseIf IsArray(arg_vList) Then
ReDim aResults(1 To UBound(arg_vList) - LBound(arg_vList) + 1, 1 To 3)
vList = arg_vList
Else
ReDim vList(1 To 1)
vList(1) = arg_vList
ReDim aResults(1 To 1, 1 To 3)
End If
dMaxMatch = 0#
lMaxIndex = 0
lResultIndex = 0
For Each vListItem In vList
If vListItem <> arg_sText Then
lLastMatch = -arg_lMinConsecutive
lResultIndex = lResultIndex + 1
aResults(lResultIndex, 3) = vListItem
If arg_bExactCount Then dExactCounts.RemoveAll
For i = 1 To Len(arg_sText) - arg_lMinConsecutive + 1
bMatch = False
sLetter = Mid(arg_sText, i, arg_lMinConsecutive)
If Not arg_bMatchCase Then sLetter = LCase(sLetter)
If arg_bExactCount Then dExactCounts(sLetter) = dExactCounts(sLetter) + 1
Select Case Abs(arg_bMatchCase) + Abs(arg_bExactCount) * 2
Case 0
'MatchCase is false and ExactCount is false
If InStr(1, vListItem, sLetter, vbTextCompare) > 0 Then bMatch = True
Case 1
'MatchCase is true and ExactCount is false
If InStr(1, vListItem, sLetter) > 0 Then bMatch = True
Case 2
'MatchCase is false and ExactCount is true
If Len(vListItem) - Len(Replace(vListItem, sLetter, vbNullString, Compare:=vbTextCompare)) >= dExactCounts(sLetter) Then bMatch = True
Case 3
'MatchCase is true and ExactCount is true
If Len(vListItem) - Len(Replace(vListItem, sLetter, vbNullString)) >= dExactCounts(sLetter) Then bMatch = True
End Select
If bMatch Then
aResults(lResultIndex, 1) = aResults(lResultIndex, 1) + WorksheetFunction.Min(arg_lMinConsecutive, i - lLastMatch)
lLastMatch = i
End If
Next i
If Len(vListItem) > 0 Then
aResults(lResultIndex, 2) = aResults(lResultIndex, 1) / Len(vListItem)
If aResults(lResultIndex, 2) > dMaxMatch Then
dMaxMatch = aResults(lResultIndex, 2)
lMaxIndex = lResultIndex
End If
Else
aResults(lResultIndex, 2) = 0
End If
End If
Next vListItem
If dMaxMatch = 0# Then
Select Case arg_lOutput
Case 1: FuzzyMatch = 0
Case 2: FuzzyMatch = vbNullString
Case Else: FuzzyMatch = CVErr(xlErrNum)
End Select
Else
Select Case arg_lOutput
Case 1: FuzzyMatch = Application.Min(1, aResults(lMaxIndex, 2))
Case 2: FuzzyMatch = aResults(lMaxIndex, 3)
Case Else: FuzzyMatch = CVErr(xlErrNum)
End Select
End If
End Function
只使用列A和B中的原始数据，您可以使用此UDF在列C和D中获得所需的结果：
在单元格C2并向下复制的是以下公式：
=FuzzyMatch($B2,$B$2:$B$6,COLUMN(A2),2)
在单元格D2中并复制下来的是这个公式：
=IFERROR(INDEX(A:A,MATCH(FuzzyMatch($B2,$B$2:$B$6,COLUMN(B2),2),B:B,0)),"-")
FuzzyMatch UDF。arg_lMinConsecutive并已更新答案。请注意公式中额外的参数，结尾处为2，它表示必须匹配至少两个连续字符。您可以将此定制为任何正整数，只要它是正整数即可。如果省略此参数，该公式将假定MinConsecutive为1（原始行为）。 - tigeravatarbMatch变量来减少重复代码（最终结果没有变化，这只是为了代码优化）。 - tigeravatar我真的没有完全理解整个逻辑，但如果你需要100%的逻辑在这里：
Option Explicit
Sub TestMe()
Dim rngCell As Range
Dim rngCell2 As Range
Dim lngTotal As Long
Dim lngTotal2 As Long
Dim lngCount As Long
For Each rngCell In Sheets(1).Range("A1:A5")
For Each rngCell2 In Sheets(1).Range("A1:A5")
If rngCell.Address <> rngCell2.Address Then
If InStr(1, rngCell, rngCell2) Then
rngCell.Offset(0, 1) = 1
Else
If InStr(1, rngCell2, rngCell) Then
rngCell.Offset(0, 2) = Round(CDbl(Len(rngCell) / Len(rngCell2)), 2)
End If
End If
End If
Next rngCell2
Next rngCell
End Sub
