十万行Excel数据下关键词匹配高效实现方案咨询

问题说明 #

现有Excel表格结构：

• A列：产品名称
• E列：关键词（由1-3个词组成）
• F列：对应目录名称

需求：当产品名称包含某一关键词的所有词时，在B列填入该关键词对应的目录名称；一旦产品匹配成功，不再参与后续关键词匹配。

当前数据量超10万行，原嵌套循环VBA代码运行效率极低，需通过数组、字典等方式优化匹配速度。

原VBA代码 #

Sub MatchinKeyWords()
    Dim keyWordsArr, productNameArr
    Dim i As Long, x As Long, N As Long
    Dim keyword, productWord
    Dim matchFound As Boolean
    Dim matchedRows() As Boolean

    ' Load arrays from ranges
    productNameArr = Range("A1").CurrentRegion.Value
    keyWordsArr = Range("D1").CurrentRegion.Value

    ' Initialize the array to track matched rows
    ReDim matchedRows(LBound(productNameArr, 1) To UBound(productNameArr, 1))
    For i = LBound(matchedRows) To UBound(matchedRows)
        matchedRows(i) = False
    Next i

    ' Iterate over keyWordsArr
    For i = LBound(keyWordsArr, 1) + 1 To UBound(keyWordsArr, 1)
        keyword = Split(keyWordsArr(i, 1))

        ' Check against each productNameArr
        For x = LBound(productNameArr, 1) + 1 To UBound(productNameArr, 1)
            ' Skip if this productNameArr row was already matched
            If matchedRows(x) Then GoTo NextProduct

            productWord = Split(productNameArr(x, 1))
            matchFound = True

            ' Check each keyword
            For N = LBound(keyword) To UBound(keyword)
                If IsError(Application.Match(keyword(N), productWord, 0)) Then
                    matchFound = False
                    Exit For
                End If
            Next N

            ' If match is found
            If matchFound Then
                productNameArr(x, 2) = keyWordsArr(i, 2) ' Fill in the match info
                matchedRows(x) = True ' Mark this row as matched
            End If

NextProduct:
        Next x
    Next i

    ' Print updated productNameArr to the worksheet
    Range("A1").Resize(UBound(productNameArr, 1), UBound(productNameArr, 2)).Value = productNameArr
End Sub

原代码逻辑：将关键词拆分为单个词，产品名称也拆分为单个词；若关键词的所有词都能在产品名称的词中找到匹配，则填充目录并标记该行已匹配。

优化后的VBA代码 #

Sub FastKeywordMatch()
    Dim productArr As Variant, keywordArr As Variant
    Dim matchedRows() As Boolean
    Dim i As Long, j As Long, k As Long
    Dim productWords As Object ' Scripting.Dictionary
    Dim keywordParts As Variant
    Dim matchSuccess As Boolean
    
    ' 禁用Excel界面更新，提升速度
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    
    ' 加载数据到数组（避免频繁读写工作表）
    productArr = Range("A1").CurrentRegion.Value
    keywordArr = Range("E1:F" & Cells(Rows.Count, "E").End(xlUp).Row).Value
    
    ' 初始化已匹配行标记数组
    ReDim matchedRows(LBound(productArr, 1) To UBound(productArr, 1))
    For i = LBound(matchedRows) To UBound(matchedRows)
        matchedRows(i) = False
    Next i
    
    ' 遍历每个产品
    For i = LBound(productArr, 1) + 1 To UBound(productArr, 1)
        If matchedRows(i) Then GoTo NextProduct
        
        ' 将当前产品名称拆分为词，存入字典（O(1)查找效率）
        Set productWords = CreateObject("Scripting.Dictionary")
        productWords.CompareMode = vbTextCompare ' 不区分大小写，按需调整
        For Each word In Split(productArr(i, 1))
            If Not productWords.Exists(word) Then
                productWords.Add word, True
            End If
        Next word
        
        ' 遍历关键词，查找匹配
        matchSuccess = False
        For j = LBound(keywordArr, 1) + 1 To UBound(keywordArr, 1)
            keywordParts = Split(keywordArr(j, 1))
            matchSuccess = True
            
            ' 检查关键词的所有词是否都在产品词字典中
            For k = LBound(keywordParts) To UBound(keywordParts)
                If Not productWords.Exists(keywordParts(k)) Then
                    matchSuccess = False
                    Exit For
                End If
            Next k
            
            ' 匹配成功则填充目录，标记已匹配并跳出关键词循环
            If matchSuccess Then
                productArr(i, 2) = keywordArr(j, 2)
                matchedRows(i) = True
                Exit For
            End If
        Next j
        
NextProduct:
        Set productWords = Nothing ' 释放对象内存
    Next i
    
    ' 将结果写回工作表
    Range("A1").Resize(UBound(productArr, 1), UBound(productArr, 2)).Value = productArr
    
    ' 恢复Excel设置
    Application.ScreenUpdating = True
    Application.EnableEvents = True
End Sub

关键优化点说明 #

1. 哈希表（字典）加速词匹配：将产品名称拆分后的词存入Scripting.Dictionary，判断词是否存在的时间复杂度从O(n)降至O(1)，替代原代码中效率低下的Application.Match。
2. 调整循环顺序：先遍历产品，再对每个未匹配产品遍历关键词；一旦匹配成功立即跳出关键词循环，避免不必要的遍历。
3. 禁用界面更新：关闭ScreenUpdating和EnableEvents，减少Excel界面渲染开销。
4. 内存优化：每次循环后释放字典对象，避免内存泄漏。

额外提速建议：

• 对关键词按词的数量分组（先匹配1词关键词，再2词，最后3词），减少匹配次数
• 使用早期绑定Scripting.Dictionary（需添加引用：工具→引用→Microsoft Scripting Runtime），比CreateObject略快

内容的提问来源于stack exchange，提问作者Francisco Augusto Varela Aguir