使用另一张表格中的列表中的单词搜索列，然后将每行的相关单词粘贴到另一列中

Question

我有一张表，其中一些列合并在一些行中。 （当列表中有新供应商时，该行有时会合并到 J，有时会合并到 L。）

我正在 C 列中查找出现在另一张表的列表中的单词（以便其他人将来添加到列表中），如果有，那么我希望将搜索到的单词输入到 K 列中。

一些单词列表：
紧急
被追了
追逐，
沉重，追逐
逾期

数据示例

A	B	C	D	E	F	G	H	我	J	K
供应商1
		（紧急）12345
		(DD)12345
		（追）12345
供应商2
		（紧急）23-PM1688-12345
		(追)4632890336-mYNU
		98765
		987654
		（重追）AB
		（chk笔记）至尊
供应商3
		飞机
		（逾期）洞穴出租
		（紧急）篮子 04/2024

宏需要搜索 C 列，如果它从另一张表中找到一个单词，则将该单词粘贴到 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

SetmyRange1 = 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

Answer 1

请。试试这个模组。 （仅供参考：合并不允许将值分配到合并范围左上角以外的其他单元格中。）K 列不能包含任一方向的合并单元格。

Sub Comment()
    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("A1:A" & Worksheets("Words").Range("A1").End(xlDown).Row) '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
            myRange1.Parent.Cells(FoundCell.Row, "K") = myCell1 & ", " & myRange1.Parent.Cells(FoundCell.Row, "K")       'inserted
            '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

编辑 我试图留下你的代码结构。 myRange3 被缩小到列的实际大小。它要求“单词”表上 A 列中要搜索的值之间不能有空单元格。

必要的一行在错误的位置被注释掉了。

找到的单词放置在与查找列所在的同一工作表的 K 列中。