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.
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
Advertisement