Excel宏需求：匹配跨表关键词并写入对应行K列

需求说明 #

• 当前工作表存在合并单元格（供应商行有时合并至J列，有时至L列）
• 需要在当前工作表C列中匹配Words工作表A列的关键词（示例：Urgent、Chased、Chasing、Heavy Chasing、Overdue）
• 匹配成功时，将对应关键词写入同一行的K列

数据示例 #

现有代码问题 #

现有宏代码仅能按关键词列表顺序统计出现次数并写入K列，无法将匹配到的关键词写入对应数据行。代码如下：

Sub Comments()

Dim FoundCell As Range
Dim LastCell As Range
Dim FirstAddr As String
Dim myRange1 As Range
Dim myRange2 As Range
Dim myRange3 As Range
Dim myCell1 As Range
Dim myCell2 As Range
Dim myStr As String
Dim myCounter As Long

Set myRange1 = ActiveSheet.Range("C:C") 'Cells where you want to search

Set myRange2 = Worksheets("Sheet6").Range("K3") 'First cell of the output list

Set myRange3 = Worksheets("Words").Range("A:A") 'Cells that contain the words we're searching

With myRange1 '(Cells where you want to search)
    Set LastCell = .Cells(.Cells.Count)
End With

For Each myCell1 In myRange3 '(Cells that contain the words we're searching)

    Set FoundCell = myRange1.Find(What:=myCell1, after:=LastCell)

    If Not FoundCell Is Nothing Then FirstAddr = FoundCell.Address

    Do Until FoundCell Is Nothing

        For Each myCell2 In myRange3
        
        Next myCell2

        With myRange2 '(First cell of the output list)
            .Offset(myCounter, 1) = myCell1
            .Offset(myCounter, 0) = FoundCell.Offset(0, -2)
            .Offset(myCounter, 2) = myStr
        End With

        myStr = vbNullString

        myCounter = myCounter + 1

        Set FoundCell = myRange1.FindNext(after:=FoundCell)

        If FoundCell.Address = FirstAddr Then
            Exit Do
        End If

    Loop

Next myCell1

End Sub

修复后的宏代码 #

Sub MatchKeywordsToKColumn()
    Dim wsCurrent As Worksheet
    Dim wsWords As Worksheet
    Dim lastRowCurrent As Long
    Dim lastRowWords As Long
    Dim i As Long, j As Long
    Dim cCellValue As String
    Dim keyword As String
    
    ' 设置工作表对象
    Set wsCurrent = ActiveSheet
    Set wsWords = ThisWorkbook.Worksheets("Words")
    
    ' 获取数据最后行号
    lastRowCurrent = wsCurrent.Cells(wsCurrent.Rows.Count, "C").End(xlUp).Row
    lastRowWords = wsWords.Cells(wsWords.Rows.Count, "A").End(xlUp).Row
    
    ' 遍历当前工作表C列每一行
    For i = 1 To lastRowCurrent
        cCellValue = UCase(Trim(wsCurrent.Cells(i, "C").Value))
        ' 跳过空单元格
        If cCellValue <> "" Then
            ' 遍历Words工作表的关键词
            For j = 1 To lastRowWords
                keyword = UCase(Trim(wsWords.Cells(j, "A").Value))
                If keyword <> "" Then
                    ' 检查C列单元格是否包含关键词
                    If InStr(1, cCellValue, keyword) > 0 Then
                        ' 将关键词写入同一行K列
                        wsCurrent.Cells(i, "K").Value = wsWords.Cells(j, "A").Value
                        ' 找到匹配后退出内层循环，避免多个关键词覆盖
                        Exit For
                    End If
                End If
            Next j
        End If
    Next i
    
    ' 释放对象
    Set wsCurrent = Nothing
    Set wsWords = Nothing
    
    MsgBox "关键词匹配完成！", vbInformation
End Sub

代码关键点说明 #

• 忽略大小写：通过UCase()统一转换为大写进行匹配，兼容示例中(URGENT)、(Chasing)等大小写混合的情况
• 处理合并单元格：直接按行遍历，不受合并单元格影响（合并单元格的行号仍正常识别）
• 精准写入：找到匹配关键词后直接写入对应行的K列，解决原代码错位问题
• 避免空值干扰：跳过空单元格和空关键词，提升运行效率
• 单次匹配优先：找到第一个匹配的关键词后就停止内层循环，避免同一单元格多个关键词时被覆盖（若需保留所有匹配，可移除Exit For并改用拼接方式）

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