VBA to search column C with words from a list in another sheet and then paste the relevant word for each row in column L

Question

Rookie here with minimal knowledge of vba trying to get a sheet of mine to work. My search has taken me to just about everything else and if I understood vba language more I could maybe amend the code to suit my need. First I'll explain what I want and then what I've done so far:

What I want- I have a sheet where some columns are merged in some rows (When there's a new supplier in the list that row will be merged sometimes to J sometimes to L), where I'm looking to see in column C if there are words that appear on list in another sheet (so as to let others add to the list in future) and if there are then I want the searched word (from the other sheet) to be input into column K.

Here's a list of some words I need to search: Urgent Chased, Chasing, Heavy, Chasing Overdue

Here's an example of the data I have

A	B	C	D	E	F	G	H	I	J	K
SUPPLIER 1
		(URGENT) 12345
		(DD)12345
		(CHASED)12345
SUPPLIER 2
		(URGENT)23-PM1688-12345
		(Chasing) 4632890336-mYNU
		98765
		987654
		(Heavy Chasing)AB
		(chk notes)supreme
SUPPLIER 3
		PLANE
		(OVERDUE) BURROW RENTAL
		(URGENT) BASKET 04/2024

So the macro needs to search Column C and then if it finds a word from the other sheet then it pastes that word into column K. There is data in the other columns and some of the columns are merged.

What I have so far

From searching I've found a macro that I've manipulated but I'm just not getting it to work, it will search the list and find how many times it finds the word and paste it in K but in the order it shows in the list rather than in the same row the data is in:

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

Pls. try this mod. (FYI: Merging doesn't let to assign values into other cells than the top left of the merged range.) Column K cannot contain merged cells in either direction.

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

Edit I tried to leave your code structure. myRange3 was reduced to the actual size of the column. It requires that there cannot be empty cell between the values to search in column A on "Words" sheet.

A necessary line was commented out in a wrong position.

The found words are placed in column K on the same sheet where the lookup column is.