Find multiple strings, copy entire row and paste into another sheet - excel

Question

I need to find certain names on a worksheet, copy the entire row once it finds said name and paste it on another worksheet.
I wrote code that finds one of the names, then copies the row and pastes it to another sheet.
Sub Macro2()
Dim StatusCol As Range
Dim Status As Range
Dim PasteCell As Range
Set StatusCol = Sheet10.Range("A1:AV1569")
For Each Status In StatusCol
If Sheet11.Range("A2") = "" Then
Set PasteCell = Sheet11.Range("A2")
Else
Set PasteCell = Sheet11.Range("A1").End(xlDown).Offset(1, 0)
End If
If Status = "Jane Thompson" Then Status.Offset(0, -4).Resize(1, 5).Copy PasteCell
Next Status
End Sub
Instead of finding only one string, the "Jane Thompson" name, I want to loop through a list of names, find each, copy the entire row where they are located and paste the row into another sheet. I have all the names on another worksheet (about 80 different names)
I managed to find code that gives me the desired output:
Sub FruitBasket()
Dim rngCell As Range
Dim lngLstRow As Long
Dim strFruit() As String
Dim intFruitMax As Integer
intFruitMax = 3
ReDim strFruit(1 To intFruitMax)
strFruit(1) = "Fruit 2"
strFruit(2) = "Fruit 5"
strFruit(3) = "Fruit 18"
lngLstRow = ActiveSheet.UsedRange.Rows.Count
For Each rngCell In Range("A2:A" & lngLstRow)
For i = 1 To intFruitMax
If strFruit(i) = rngCell.Value Then
rngCell.EntireRow.Copy
Sheets("Inventory").Select
Range("A65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial xlPasteValues
Sheets("Fruit").Select
End If
Next i
Next
End Sub
But instead of 3 items in the array, I had to hard code 81 names. Is there any way to pull the items of an array from another sheet?

Answer 1

With the names in an array you can use Match rather than looping through them.
Option Explicit
Sub FruitBasket()
Dim ws As Worksheet, wsInv As Worksheet
Dim rngCell As Range, v As Variant, arNames
Dim lngLastRow As Long, lngInvRow As Long
With Sheets("Names")
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
arNames = .Range("A2:A" & lngLastRow)
End With
Set wsInv = Sheets("Inventory")
With wsInv
lngInvRow = .Cells(.Rows.Count, "A").End(xlUp).Row
End With
Application.ScreenUpdating = False
Set ws = ActiveSheet
With ws
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
For Each rngCell In .Range("A2:A" & lngLastRow)
' check if value is in array
v = Application.Match(rngCell, arNames, 0)
If IsError(v) Then
' no match
Else
' match
rngCell.EntireRow.Copy
lngInvRow = lngInvRow + 1
wsInv.Cells(lngInvRow, "A").PasteSpecial xlPasteValues
End If
Next
End With
Application.CutCopyMode = False
Application.ScreenUpdating = True
MsgBox "Done"
End Sub