Find/copy/paste in new worksheet

QuestionEdit

I need to find names from a list on anworksheet. The keyword list is 250+ names. I need to search the worksheet and copy the found names to anotherworksheet location (if found). Sub CopyNames()

Dim DestSheet As Worksheet Set DestSheet = Worksheets("Least Seniors & Trips")

Dim sRow As Long Dim dRow As Long Dim sCount As Long sCount = 0 dRow = 4

Sheets("EARLY").Select For sRow = 1 To Range("H75").End(xlUp).Row If Cells(sRow, "H") Like "*Name*" Then sCount = sCount + 1 dRow = dRow + 1 Cells(sRow, "H").Copy Destination:=DestSheet.Cells(dRow, "G")

End If Next sRow 'copy cols A,F,E & D Sheets("EARLY").Select For sRow = 1 To Range("K75").End(xlUp).Row If Cells(sRow, "K") Like "*Name*" Then sCount = sCount + 1 dRow = dRow + 1 Cells(sRow, "K").Copy Destination:=DestSheet.Cells(dRow, "G")

End If Next sRow MsgBox sCount & " Least Senior copied", vbInformation, "Transfer Done"

End Sub

This does what i want but i cannot copy this 250+ times. I need to search using a keyword list. I would like to also include a search of another column for repeat names and elliminate names if they are in said column. Let me know if you can help.

AnswerEdit

So this code first loops through col H and copies every cell in that column which contains "Name" to the destination sheet col. G. After that it repeats this for column K, correct?

Suppose the list of names you want the code to look for is located on a sheet called "List", then this code might do what you need:

Sub CopyNames()

   Dim DestSheet As Worksheet
   Set DestSheet = Worksheets("Least Seniors & Trips")

   Dim sRow As Long
   Dim dRow As Long
   Dim sCount As Long
   Dim oSearchCell As Range
   sCount = 0
   dRow = 4

   Sheets("EARLY").Select
   For Each oSearchCell In Sheets("List").Range("A2:A251")
       For sRow = 1 To Range("H75").End(xlUp).Row
           If Cells(sRow, "H") Like "*" & oSearchCell.Value & "*" Then
               sCount = sCount + 1
               dRow = dRow + 1
               Cells(sRow, "H").Copy Destination:=DestSheet.Cells(dRow, "G")

           End If
       Next sRow    'copy cols A,F,E & D
       Sheets("EARLY").Select
       For sRow = 1 To Range("K75").End(xlUp).Row
           If Cells(sRow, "K") Like "*" & oSearchCell.Value & "*" Then
               sCount = sCount + 1
               dRow = dRow + 1
               Cells(sRow, "K").Copy Destination:=DestSheet.Cells(dRow, "G")

           End If
       Next sRow
   Next oSearchCell
   MsgBox sCount & " Least Senior copied", vbInformation, "Transfer Done"

End Sub