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

 

[GWteB]

Hi graceface21, welcome to MrExcel.

It's not entirely clear to me what exactly you want. You can help us with helping you, by providing sample data, both from the initial situation and the desired final situation.
Please use the XL2BB tool for this, which you can download from this site over here ...

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

 

[Fluff]

With a key word of sad, would you want it to return a cell with the value of saddle?

 

[graceface21]

Hi graceface21, welcome to MrExcel.

It's not entirely clear to me what exactly you want. You can help us with helping you, by providing sample data, both from the initial situation and the desired final situation.
Please use the XL2BB tool for this, which you can download from this site over here ...

XL2BB - Excel Range to BBCode

Excel 'mini-sheet' in messages - XL2BB Although experts prefer to read your description and question instead of working in your actual file to solve your problem, there are times that it is difficult to explain an issue without providing actual...

www.mrexcel.com

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

 

[graceface21]

With a key word of sad, would you want it to return a cell with the value of saddle?

Sort of, please review my reply below for clarity! I appreciate your time so much!

 

[Fluff]

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

 

[graceface21]

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

Can you explain why we would be checking for the value in an empty cell for column B? (InStr check/explanation)

 

[Fluff]

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

the found values are in column B

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?

 

[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?

Sorry the details tab is in Column D not B! The found words are supposed to be placed in column C not B. This is a typo in my code

 

[Fluff]

Ok, 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, "D").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, "D").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