Filtering by list of keywords and pasting results into spreadsheet

Try this.

Sub x()
    Dim rTest       As Range
    Dim rLook       As Range
    Dim rFind       As Range
    Dim sAddr       As String
    Dim iRow        As Long

    With Me
        Set rTest = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
    End With

    With Sheet2
        Set rLook = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
    End With

    For iRow = rTest.Rows.Count To 1 Step -1
        Set rFind = rLook.Find(What:=rTest(iRow).Text, After:=rLook(1), _
                               SearchDirection:=xlPrevious, _
                               MatchCase:=False, MatchByte:=False, _
                               SearchFormat:=False)
        If Not rFind Is Nothing Then
            sAddr = rFind.Address
            
            Do
                Application.CutCopyMode = False
                With rTest(iRow, 1)
                    .EntireRow.Copy
                    .Offset(1).Insert
                    rFind.EntireRow.Resize(, Columns.Count - 1).Copy Destination:=.Offset(1, 1)
                End With
                Set rFind = rLook.Find(What:=rTest(iRow).Text, After:=rFind, _
                                       SearchDirection:=xlPrevious)
            Loop Until rFind.Address = sAddr
        End If
            
        rTest(iRow, 1).EntireRow.Delete
    Next iRow
    
    Application.CutCopyMode = xlCopy
End Sub

Sure, that would be another approach.

Turning screenupdating off during execution would speed the existing code.