VBA优化需求：基于参考关键词提取产品标题收件人

需求说明 #

• PRODUCTS工作表存储产品详情，需将「Product Title」列匹配到对应收件人类别
• REFERENCE工作表A列为关键词，B列为对应收件人
• 匹配结果写入PRODUCTS表的「Recipient From Title」列，多匹配结果用分号分隔

现有代码问题 #

1. 嵌套循环在大数据集（500+至10万行）下运行效率极低
2. 存在错误匹配：
   • 短关键词「Mum」会误匹配包含它的长词「Grandmum」
   • 「God Daughter」被错误识别为「Daughter」，正确应归属「Godchild」

优化后的VBA代码 #

Sub FillRecipientFromTitle()
    Dim wsProducts As Worksheet, wsReference As Worksheet
    Dim arrProducts As Variant, arrReference As Variant
    Dim dictKeywords As Object, dictRecipients As Object
    Dim i As Long, j As Long
    Dim title As String, recipientStr As String
    Dim wordsInTitle As Variant, word As Variant
    Dim matchedRecipients As Collection
    
    ' 初始化工作表
    Set wsProducts = ThisWorkbook.Sheets("PRODUCTS")
    Set wsReference = ThisWorkbook.Sheets("REFERENCE")
    Set dictKeywords = CreateObject("Scripting.Dictionary")
    Set dictRecipients = CreateObject("Scripting.Dictionary")
    
    ' 读取数据到数组（大幅提升读写速度）
    arrProducts = wsProducts.Range("A2:B" & wsProducts.Cells(wsProducts.Rows.Count, 1).End(xlUp).Row).Value
    arrReference = wsReference.Range("A2:B" & wsReference.Cells(wsReference.Rows.Count, 1).End(xlUp).Row).Value
    
    ' 构建关键词-收件人映射，优先存储长关键词（避免短词误匹配）
    For i = LBound(arrReference) To UBound(arrReference)
        Dim key As String
        key = LCase(Trim(arrReference(i, 1)))
        If key <> "" Then
            Dim lenKey As Integer
            lenKey = Len(key)
            If Not dictKeywords.Exists(lenKey) Then
                Set dictKeywords(lenKey) = CreateObject("Scripting.Dictionary")
            End If
            If Not dictKeywords(lenKey).Exists(key) Then
                dictKeywords(lenKey).Add key, arrReference(i, 2)
            End If
        End If
    Next i
    
    ' 按关键词长度从长到短排序键值
    Dim sortedLengths As Variant
    sortedLengths = dictKeywords.Keys
    For i = LBound(sortedLengths) To UBound(sortedLengths) - 1
        For j = i + 1 To UBound(sortedLengths)
            If sortedLengths(i) < sortedLengths(j) Then
                Dim temp As Integer
                temp = sortedLengths(i)
                sortedLengths(i) = sortedLengths(j)
                sortedLengths(j) = temp
            End If
        Next j
    Next i
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    ' 处理每条产品标题
    For i = LBound(arrProducts) To UBound(arrProducts)
        title = LCase(Trim(arrProducts(i, 1)))
        Set matchedRecipients = New Collection
        recipientStr = ""
        
        If title <> "" Then
            ' 按长关键词优先匹配，避免短词误匹配
            For j = LBound(sortedLengths) To UBound(sortedLengths)
                Dim currentLen As Integer
                currentLen = sortedLengths(j)
                Dim keyDict As Object
                Set keyDict = dictKeywords(currentLen)
                
                ' 遍历当前长度的所有关键词
                For Each key In keyDict.Keys
                    ' 使用正则表达式匹配完整单词（避免部分匹配）
                    Dim regex As Object
                    Set regex = CreateObject("VBScript.RegExp")
                    regex.Global = False
                    regex.IgnoreCase = True
                    regex.Pattern = "\b" & key & "\b"
                    
                    If regex.Test(title) Then
                        Dim recipient As String
                        recipient = keyDict(key)
                        ' 避免重复添加同一收件人
                        On Error Resume Next
                        matchedRecipients.Add recipient, Key:=recipient
                        On Error GoTo 0
                    End If
                Next key
            Next j
        End If
        
        ' 将收集到的收件人转为分号分隔的字符串
        If matchedRecipients.Count > 0 Then
            For Each recipient In matchedRecipients
                recipientStr = recipientStr & ";" & recipient
            Next recipient
            recipientStr = Mid(recipientStr, 2)
        End If
        
        ' 写入结果到数组
        arrProducts(i, 2) = recipientStr
    Next i
    
    ' 将数组数据批量写入工作表
    wsProducts.Range("A2:B" & UBound(arrProducts) + 1).Value = arrProducts
    
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
    MsgBox "数据处理完成！"
End Sub

优化说明 #

1. 效率提升 #

• 数组读写替代单元格循环：一次性将数据读取到内存数组，处理完成后批量写入，避免频繁读写单元格的IO开销，大数据集下速度提升显著
• 字典存储关键词：利用字典的快速查找特性，替代嵌套循环遍历，减少匹配次数
• 关闭屏幕更新与自动计算：临时禁用Excel的屏幕刷新和自动计算，进一步提升运行速度

2. 精确匹配解决 #

• 长关键词优先匹配：将关键词按长度降序排序，优先匹配长关键词（如先匹配「God Daughter」再匹配「Daughter」），避免短词覆盖长词的正确匹配
• 正则表达式完整单词匹配：使用\b单词边界正则规则，确保匹配的是独立单词（如「Mum」不会匹配「Grandmum」中的部分字符）
• 去重处理：通过集合存储匹配到的收件人，自动避免同一收件人重复添加

内容的提问来源于stack exchange，提问作者Gen