Possibly...
Sub Copy_and_Paste_Whole_Rows()
Dim vData As Variant
Dim vFind As Variant
Dim a As Integer
Dim b As Long
Dim c As Integer
Dim StartRow As Long
Dim rData As Range
Application.ScreenUpdating = False
StartRow = 15
With Worksheets("Sheet2")
Set rData = Application.Intersect(.Range("F:O"), .UsedRange)
vData = rData
vFind = Worksheets("Sheet1").Range("D3:D7")
For a = LBound(vFind) To UBound(vFind)
For b = LBound(vData, 1) To UBound(vData, 1)
For c = LBound(vData, 2) To UBound(vData, 2)
If vFind(a, 1) = vData(b, c) Then
.Rows(b).Copy Worksheets("Sheet1").Rows(StartRow)
StartRow = StartRow + 1
End If
Next c
Next b
Next a
End With
Application.ScreenUpdating = True
End Sub
Bookmarks