资讯

历史

科技

环境与自然

成长

游戏

财经

文学与艺术

美食

健康

家居

文化

情感

汽车

三农

军事

旅行

运动

教育

生活

星座命理

VBA字符串处理进阶：文本相似度与模糊匹配函数封装

创作时间:

作者:

@小白创作中心

VBA字符串处理进阶：文本相似度与模糊匹配函数封装

引用

360doc个人图书馆

等

来源

http://www.360doc.cn/article/67367384_1013795555.html

https://wenku.csdn.net/doc/2yhqvbgbx5

https://blog.csdn.net/oHuaXiaZhiFeng/article/details/8620486

http://www.360doc.cn/article/68414255_925983951.html

http://www.360doc.cn/article/13664199_947520250.html

https://blog.csdn.net/u011785661/article/details/50697529

https://blog.csdn.net/woodcorpse/article/details/116036330

https://blog.csdn.net/ych_ding/article/details/42266603

https://cloud.tencent.com/developer/ask/sof/103025342/answer/111191535

10.

https://www.cnblogs.com/xkdn/p/17850005.html

11.

https://www.exceldemy.com/calculate-levenshtein-distance-in-excel/

12.

https://www.cnblogs.com/apachecn/p/18473566

基于前面的分析和规划，我为您封装了一组进阶的文本处理函数。这些函数包括文本相似度计算、模糊匹配以及必要的预处理功能，旨在帮助您在VBA中更高效地处理字符串数据。

字符串相似度计算

SimilarityRatio 函数

计算两个字符串的相似度比率（0-1范围），基于编辑距离。

Public Function SimilarityRatio(ByVal str1 As String, ByVal str2 As String) As Double
    Dim maxLen As Long
    str1 = CleanString(str1)
    str2 = CleanString(str2)
    
    If str1 = str2 Then
        SimilarityRatio = 1
        Exit Function
    End If
    
    maxLen = WorksheetFunction.Max(Len(str1), Len(str2))
    SimilarityRatio = 1 - (LevenshteinDistance(str1, str2) / maxLen)
End Function

LevenshteinDistance 函数

计算两个字符串的编辑距离，使用动态规划实现。

Public Function LevenshteinDistance(ByVal s As String, ByVal t As String) As Long
    Dim d() As Long, i As Long, j As Long, cost As Long
    Dim m As Long, n As Long
    
    m = Len(s)
    n = Len(t)
    ReDim d(0 To m, 0 To n)
    
    For i = 0 To m: d(i, 0) = i: Next
    For j = 0 To n: d(0, j) = j: Next
    
    For i = 1 To m
        For j = 1 To n
            cost = Abs(StrComp(Mid(s, i, 1), Mid(t, j, 1), vbTextCompare))
            d(i, j) = WorksheetFunction.Min( _
                d(i - 1, j) + 1, _
                d(i, j - 1) + 1, _
                d(i - 1, j - 1) + cost)
        Next
    Next
    
    LevenshteinDistance = d(m, n)
End Function

JaccardSimilarity 函数

基于词集计算两个字符串的Jaccard相似度。

Public Function JaccardSimilarity(ByVal strA As String, ByVal strB As String) As Double
    Dim wordsA As Variant, wordsB As Variant
    Dim union As Collection, intersect As Collection
    
    Set union = New Collection
    Set intersect = New Collection
    
    wordsA = Split(RemoveNonAlphanumeric(strA), " ")
    wordsB = Split(RemoveNonAlphanumeric(strB), " ")
    
    '计算并集和交集
    BuildUnionAndIntersect wordsA, wordsB, union, intersect
    
    If union.Count = 0 Then
        JaccardSimilarity = 0
    Else
        JaccardSimilarity = intersect.Count / union.Count
    End If
End Function

模糊匹配

FuzzyMatch 函数

在Excel单元格区域中查找与目标字符串相似的项，返回匹配单元格地址及相似度。

Public Function FuzzyMatch(ByVal searchStr As String, ByVal rangeToSearch As Range, Optional threshold As Double = 0.7) As Variant
    Dim result() As Variant, cell As Range, cnt As Long
    ReDim result(1 To rangeToSearch.Count, 1 To 2)
    
    searchStr = CleanString(searchStr)
    
    For Each cell In rangeToSearch
        If SimilarityRatio(searchStr, CleanString(cell.Value)) >= threshold Then
            cnt = cnt + 1
            result(cnt, 1) = cell.Address
            result(cnt, 2) = Format(SimilarityRatio(searchStr, cell.Value), "0.00%")
        End If
    Next
    
    ReDim Preserve result(1 To cnt, 1 To 2)
    FuzzyMatch = result
End Function

辅助函数

CleanString 函数

清洗字符串，去除特殊字符，统一转换为小写。

Public Function CleanString(ByVal str As String) As String
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    
    With regex
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^a-zA-Z0-9\s]"
        CleanString = .Replace(str, "")
    End With
    
    CleanString = LCase(CleanString)
End Function

RemoveNonAlphanumeric 函数

去除字符串中的非字母数字字符。

Public Function RemoveNonAlphanumeric(ByVal str As String) As String
    Dim regex As Object
    Set regex = CreateObject("VBScript.RegExp")
    
    With regex
        .Global = True
        .IgnoreCase = True
        .Pattern = "[^a-zA-Z0-9]"
        RemoveNonAlphanumeric = .Replace(str, "")
    End With
End Function

BuildUnionAndIntersect 子程序

构建两个词集的并集和交集。

Private Sub BuildUnionAndIntersect(ByRef arr1, ByRef arr2, ByRef unionColl As Collection, ByRef intersectColl As Collection)
    Dim dict As Object, elem As Variant
    Set dict = CreateObject("Scripting.Dictionary")
    
    '处理第一个数组
    For Each elem In arr1
        elem = LCase(Trim(elem))
        If Len(elem) > 0 Then
            dict(elem) = 1
            AddToCollection unionColl, elem
        End If
    Next
    
    '处理第二个数组
    For Each elem In arr2
        elem = LCase(Trim(elem))
        If Len(elem) > 0 Then
            If dict.exists(elem) Then
                If dict(elem) = 1 Then
                    AddToCollection intersectColl, elem
                    dict(elem) = 2
                End If
            Else
                AddToCollection unionColl, elem
            End If
        End If
    Next
End Sub

AddToCollection 子程序

向集合中添加元素，避免重复。

Private Sub AddToCollection(ByRef coll As Collection, ByVal item As String)
    On Error Resume Next
    coll.Add item, item
    On Error GoTo 0
End Sub

使用示例

Sub Demo()
    '相似度计算
    Debug.Print SimilarityRatio("apple", "apples")  '→ 0.8
    
    '模糊匹配查找
    Dim matches As Variant
    matches = FuzzyMatch("Excel", Range("A1:A10"), 0.6)
    
    'Jaccard相似度
    Debug.Print JaccardSimilarity("Hello world", "World hello") '→ 1.0
End Sub