用VBA简化Excel办公流程

创作时间:

作者:

@小白创作中心

用VBA简化Excel办公流程

引用

360doc个人图书馆

等

来源

http://www.360doc.cn/article/78873848_1026234072.html

https://blog.csdn.net/renyongzhe/article/details/126793884

https://blog.csdn.net/dyfgs/article/details/7177088

https://baijiahao.baidu.com/s?id=1769392456681844325

https://baijiahao.baidu.com/s?id=1802273530418543341

https://blog.csdn.net/u010454729/article/details/124231419

https://blog.csdn.net/zhangdabai1/article/details/142214759

https://www.cnblogs.com/-wenli/p/11079173.html

https://docs.pingcode.com/baike/4975684

通过掌握VBA语言的字符串处理技巧，你可以显著提高在Excel中的工作效率。无论是数据清洗、文本分析还是报表生成，VBA都能帮助你轻松应对各种复杂的办公任务。例如，使用Left、Right和Mid函数提取特定字符，或者利用Replace函数批量替换错误信息，这些操作都可以大大减少手动处理的时间。此外，VBA还提供了丰富的内置函数来实现大小写转换、字符串查找等功能，让你的工作更加高效便捷。

下面为你封装一组进阶的文本处理函数：

'► 文本相似度计算
Public Function SimilarityRatio(ByVal str1 As String, ByVal str2 As String) As Double
    '基于编辑距离计算相似度（0-1范围）
    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

'► 莱文斯坦距离计算
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

'► 模糊匹配查找
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

'► 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

'► 私有辅助方法 ◄
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

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

特点说明：