VBA循环匹配关键字如何避免覆盖前序结果、保留所有匹配项

Sub 多关键词匹配()
    Dim lRow As Long
    Dim lCol As Long
    Dim lRow2 As Long
    Dim lCol2 As Long
    Dim wordsArray() As Variant
    Dim word As Variant
    Dim cell As Range
    Dim sht As Worksheet
    Dim sht2 As Worksheet
    Dim matchResult As String ' 存储当前单元格所有匹配结果
    
    ' 先声明工作表对象
    Set sht = Worksheets("MainTable")
    Set sht2 = Worksheets("SecondaryTable")
    
    ' 先计算两个表的行列数，再赋值关键词数组，修正原代码顺序错误
    lRow = sht.Range("A1").CurrentRegion.Rows.Count
    lCol = sht.Range("A1").CurrentRegion.Columns.Count
    lRow2 = sht2.Range("A1").CurrentRegion.Rows.Count
    lCol2 = sht2.Range("A1").CurrentRegion.Columns.Count
    
    wordsArray = Worksheets("SecondaryTable").Range("A2:A" & lRow2).Value
    
    ' 遍历主表待匹配列
    For Each cell In sht.Range("I2:I" & lRow)
        matchResult = "" ' 每次遍历新单元格先清空结果
        For Each word In wordsArray
            If InStr(1, cell.Value, word, vbTextCompare) > 0 Then ' 不需要忽略大小写可删除vbTextCompare参数
                ' 匹配到就拼接结果，默认用顿号分隔，可自行替换为其他符号
                If matchResult = "" Then
                    matchResult = word
                Else
                    matchResult = matchResult & "、" & word
                End If
            End If
        Next word
        ' 所有关键词遍历完后统一赋值给目标单元格
        cell.Offset(0, -2).Value = matchResult
    Next cell
    
End Sub

核心修改说明 #

• 新增matchResult字符串变量，每次匹配到关键词时先拼接到该变量中，所有关键词遍历完成后再统一赋值给目标单元格，避免覆盖
• 修正原代码逻辑错误：将关键词数组赋值操作放到lRow2计算之后，避免数组取值范围异常
• 修正原代码语法错误：把RowsCount改为Rows.Count，补充sht、sht2的变量声明
• 可选优化：新增忽略大小写匹配逻辑，不需要可删除InStr函数中的vbTextCompare参数
• 匹配结果默认用顿号分隔，可自行修改拼接符为逗号、竖线等其他符号满足格式需求

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