VBA for Search for a Word, Cut Entire Row, & Paste on New Sheet

[tmooreiii]

Hello All,
I am trying to create a Macro that will find specific words, then cut the row that the word(s) are found in & paste all that apply in a new sheet.
I searched the forum and found some codes, but none worked for me for what I wanted.
I know a little about how to do this but cannot manage to get it. I am good at more simplistic Macros. This one is tough for me.
In the image below I am trying to cut rows that contain the words in column J and paste in different sheets.

Is there someone who could get me something close?

 

[ranman256]

in this code:
the sheet with the data is SHEET1
the sheet with the words to find is in: WORDS2FIND
(change to match yours)

then run FINDWORDS

Private mcolWords As New Collection
Private wsTarg As Worksheet, wsSrc As Worksheet
Private vWord

Sub FindWords()
On Error Resume Next
Sheets.Add
Set wsTarg = ActiveSheet
wsTarg.Name = "results"
'load the words list
Set mcolWords = New Collection
Sheets("words2Find").Activate
Range("A1").Select
While ActiveCell.Value <> ""
   vWord = ActiveCell.Value
   mcolWords.Add vWord, vWord
 
   ActiveCell.Offset(1, 0).Select  'next row
Wend

 'scan data sheet for the words. do it backwards to prevent row errors
Sheets("Sheet1").Activate
Set wsSrc = ActiveSheet
Range("A1").Select
Selection.End(xlDown).Select
While ActiveCell.Row > 1
   Find1Word
   ActiveCell.Offset(-1, 0).Select  'prev row
Wend
Set wsSrc = Nothing
Set wsTarg = Nothing
End Sub


private Function Find1Word()
Dim bFound As Boolean
Dim r, i
On Error GoTo ErrFind
bFound = False
r = ActiveCell.Row

Rows(r & ":" & r).Select
i = 1
While i <= mcolWords.Count And Not bFound
    vWord = mcolWords(i)
    Selection.Find(What:=vWord, After:=ActiveCell, LookIn:=xlFormulas, _
            LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
            MatchCase:=False, SearchFormat:=False).Activate
 
    bFound = True
    'MsgBox "found"
 
    'copy row to other sheet
    Rows(r & ":" & r).Select
    Selection.Cut
    wsTarg.Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, 0).Select  'next row
      'back to source
    wsSrc.Select
    Rows(r & ":" & r).Select
    Selection.Delete Shift:=xlUp
tryNextWord:
    i = i + 1
Wend
Exit Function
ErrFind:
If Err = 91 Then
  GoTo tryNextWord
Else
  MsgBox Err.Description, , Err
End If
End Function

 

[tmooreiii]

Thanks.
I will give it a try this afternoon and update on how it worked for me.
I really appreciate it.

 

[tmooreiii]

I created the sheets (Tabs) and named them accordingly. I only got 1 result and 1 line of that.

What I am trying to do is find the words in the worklist and cut the rows and paste on individual worksheets (perhaps pre-named to the find words).
So, the code would search for rows with "Chem Film" in column J, cut entire row(s) from "WORLIST", and paste in a Worksheet named "Chem Film".
Is this an impossible task?