Look for keywords and copy to another sheet

[ceclay]

Would like to ask for help on this code below:

I have the following Keywords:
1. Lopez
2. Antetokounmpo
3. Curry
4. Morris

If any of keyword available then it will copy to another sheet together with the next 2 cell below it.

Sub Replace18()

  
  Dim sh As Worksheet, Sr As Range, Sf As Range, wA As Variant
  Dim FindWhat As Variant
  
 FindWhat = Array("Lopez", "Antetokounmpo", "Curry", "Gasol", "Morris", "Gordon")

  
  Set sh = Sheets("NBA Outright Paste Here")
  Set Sr = sh.Range("A1:A80000")
  
  ''Points scored by the player - Including Overtime
  sRow = 2
  Set Sf = Sr.Find(FindWhat, , xlValues, xlPart)
  If Not Sf Is Nothing Then
    cell = Sf.Address
    Do
      wA = Sf.Resize(3, 1).Value
      With Sheets("Sheet1")
        .Range("A" & Rows.Count).End(xlUp)(2).Resize(3, 1).Value = wA
        .Range("C" & sRow).Resize(1, 3).Value = Application.Transpose(wA)
        sRow = sRow + 1
      End With
      Set Sf = Sr.FindNext(Sf)
    Loop While Not Sf Is Nothing And Sf.Address <> cell
  End If
  

End Sub

 

[davesexcel]

You would need to loop through the array.

Sub Button1_Click()

    Dim sh As Worksheet
    Dim Sr As Range, Sf As Range
    Dim FindWhat As Variant, wA As Variant

    FindWhat = Array _
               ("Lopez", "Antetokounmpo", "Curry", "Gasol", "Morris", "Gordon")


    Set sh = Sheets("NBA Outright Paste Here")
    
    With sh
        Set Sr = .Range("A1:A" & .Cells(.Rows.Count, "A").End(xlUp).Row)
    End With
    
    sRow = 2

    For i = LBound(FindWhat) To UBound(FindWhat)

        ''Points scored by the player - Including Overtime
        Set Sf = Sr.Find(FindWhat(i), , xlValues, xlPart)
        
        If Not Sf Is Nothing Then
            cell = Sf.Address
            
            Do
                wA = Sf.Resize(3, 1).Value
                
                With Sheets("Sheet1")
                    .Range("A" & Rows.Count).End(xlUp)(2).Resize(3, 1).Value = wA
                    .Range("C" & sRow).Resize(1, 3).Value = Application.Transpose(wA)
                    sRow = sRow + 1
                End With
                
                Set Sf = Sr.FindNext(Sf)
            Loop While Not Sf Is Nothing And Sf.Address <> cell
            
        End If
        
    Next i

End Sub

 

[ceclay]

Thank you for your help! Its working perfectly