文本相似性分析 (Excel)

Question

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

我想要的输出将类似于以下内容：

相似度列中显示的百分比纯粹是说明性的。我认为对相似性的测试应该是这样的：

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

但很想得到关于那个的意见。

这是在 Excel 上合理可行的吗？我是一个仅包含字母数字值的小型数据集 (140kb)。

我也对解决此问题的其他方法持开放态度，因为我以前没有处理过类似的事情！

附：我已经学习 Python 几个月了，所以使用 Python 的建议也很好！

Answer 1

这是使用 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。

Answer 2

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

Fuzzy string comparison in Python, confused with which library to use

Answer 3

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

请看图：