Python 文本相似性分析（Excel）

我有一个项目列表，我想确定它们与列表中其他项目的相似性

我所期望的输出将大致如下：

相似性列中显示的百分比纯粹是说明性的。我认为相似性测试应该遵循以下几点：

并发字母数/按列表中的字母总数 匹配项

但我很想得到关于这个问题的意见

这在Excel上是合理可行的吗？这是一个140kb的小数据集，只包含字母数字值

我也愿意用其他方法来解决这个问题，因为我以前从未处理过类似的问题

---

另外，我已经学习Python几个月了，所以使用Python的建议也不错

在python中，可以使用Levenshtein距离来获得结果。看看这个答案：

---

我真的没有得到全部逻辑，但是如果你需要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

这是你的照片：

---

以下是使用VBA UDF的解决方案：

编辑：添加了一个名为arg_lmunecutive的新可选参数，用于确定必须匹配的最小连续字符数。请注意以下公式中的额外参数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

在单元格D2中，向下复制的是以下公式：

=FuzzyMatch($B2,$B$2:$B$6,COLUMN(A2),2)

=IFERROR(INDEX(A:A,MATCH(FuzzyMatch($B2,$B$2:$B$6,COLUMN(B2),2),B:B,0)),"-")

---

请注意，它们都使用FuzzyMatch UDF。

只需使用instr即可，谢谢@Vityata。但是VBA不是很热门，所以不确定如何实现？谢谢你，非常感谢你的帮助！我正在尝试匹配有并发字母的单词。所以，如果我把柠檬、柠檬和黄色柠檬分为3行，我会很快识别出哪些包含柠檬这个词。所以在这个例子中，每一个都将匹配100%，然后我将快速地将它们全部转换为Lemon，以便删除相同的重复项，这些重复项只是以不同的方式输入的。这有意义吗？谢谢@vityta，非常感谢！为了确认，第一列返回100%匹配，第二列返回部分匹配。是吗？我还想在D栏测试文本，在A栏测试我的参考资料，如果这对你有影响的话？谢谢，我会调查的！谢谢你，真的很感激！这实际上非常适合我正在工作的另一个项目。然而，这并不完全是我想要为这份工作做的。我正在尝试匹配并发的字母。而不仅仅是匹配事件。所以在上面的例子中，柠檬应该等于0%。这段代码适合这样做吗？@Maverick即使对于并发字母，e和n至少会给出一个匹配。你的意思是至少两个连续的字母必须匹配吗？是的，我只是这么想。我会说至少2个，可能不超过5-10个，但如果可能的话，最好能够调整它？@Maverick我在UDF中添加了一个新的可选参数：arg_lmunecutive，并更新了答案。请注意公式中的额外参数，即末尾的2，它表示至少必须匹配两个连续字符。您可以将其自定义为您想要的任何数字，只要它是正整数。如果省略此参数，则公式将假定原始行为的最小值为1。使用新的bMatch变量略微更新UDF以减少重复代码最终结果没有变化，这只是为了代码优化