Search multiple strings and paste to adjacent column Macro

[graceface21]

Hi,

I am brand new to VBA and I want to search for a bunch of keywords in one column that contains additional text like in each cell. I want to search for the keywords in each cell and paste them to an adjacent cell all by clicking a macro. How do I accomplish this?

So far I have the follow; however, it is not copying over to the adjacent cell.
Private Sub COQ_click()

COQcodes = "happy|sad|mood"
strFind = Split(COQcodes, "|")

row_number = 0
Do
DoEvents
row_number = row_number + 1
item_in_review = Sheet5.Range("M" & row_number)
For Each iCell In Selection
For i = LBound(strFind) To UBound(strFind)
If InStr(UCase(iCell.Value), UCase(strFind(i))) > 0 Then
iCell.Offset(, 1).Resize(1, 3).Copy
GoTo NextOne
End If
Next i
NextOne:
Next iCell
Loop Until row_number = 12800
End Sub

 

[graceface21]

I was simply trying to guess your layout, from your code & this comment


Your code inserts a new col C (which will be empty), but it looks at that column, which makes no sense.
Which column has the text strings to be checked?

How about

Private Sub Search()
Sheet5.Activate
    Columns("C:C").Insert Shift:=xlToRight
    Range("C2").Value = "CODE"

    Dim lr As Long
    Dim arr
    Dim r As Long
    Dim i As Long
    Dim x As String
   
    Application.ScreenUpdating = False

'   Store all values you want to search for in an array
    arr = Array("01D, 05C, BOC, POC, 00D, OOL, ABC, 12C")
   
'   Find last row with data in column C
    lr = Cells(Rows.Count, "C").End(xlUp).Row
   
'   Loop through all rows from bottom to top
    For r = lr To 3 Step -1
'       Loop through each value in array and check for a match
        For i = LBound(arr) To UBound(arr)
'           Get value to look for
            x = arr(i)
'           Check for value
            If InStr(1, Cells(r, "B").Value, arr(i), vbTextCompare) > 0 Then
                x = x & ", " & arr(i)
            End If
        Next i
        If x <> "" Then Cells(r, "C").Value = Mid(x, 3)
        x = ""
    Next r

    Application.ScreenUpdating = True

End Sub

Currently this inserts a single character into column C whereas I want it to insert the found value in column C to column B

Hi thank you for the guidance! I will edit my question, so it's clearer. I realized that I could have done a better job at explaining what I desire.

I want my macro to search through a column for multiple strings and paste the found keywords in the string to the adjacent column. I've coded the keywords on column C in red and the found values are in column B. I want it to find the keywords and separate and append each found keyword; it does not have to be comma delimitated but that would be preferred.

Code	Details
01D, 05C, BOC	01D .5 C09 5 hr 05C BOC
POC, 00D, OOL	POC, 00D, OOL, 67 hr This was an example
ABC	This is another example; ABC, 70D
12C	I used to think I knew Excel, but I'm a novice. 12C 56 hrs of practicing

I took another shot at it based on browsing through similar questions on the Forum and got to here:

Private Sub Search()
Sheet5.Activate
    Columns("C:C").Insert Shift:=xlToRight
    Range("C2").Value = "CODE"

    Dim lr As Long
    Dim arr
    Dim r As Long
    Dim i As Long
    Dim x As String
   
    Application.ScreenUpdating = False

'   Store all values you want to search for in an array
    arr = Array("01D, 05C, BOC, POC, 00D, OOL, ABC, 12C")
   
'   Find last row with data in column C
    lr = Cells(Rows.Count, "C").End(xlUp).Row
   
'   Loop through all rows from bottom to top
    For r = lr To 3 Step -1
'       Loop through each value in array and check for a match
        For i = LBound(arr) To UBound(arr)
'           Get value to look for
            x = arr(i)
'           Check for value
            If Left(Cells(r, "C"), Len(x)) = x Then
'               If value found, copy row and exit inner for loop - Copy over just the 3 digit code and append it to the cell either with a space or comma (NEED HELP HERE) InStr?
                Cells(r, "B") = Left(Cells(r, "C"), 3)
                Exit For
                End If
            End If
        Next i
    Next r

    Application.ScreenUpdating = True

End Sub