Filtering by list of keywords and pasting results into spreadsheet

Basically I have two Spreadsheets, lets call it Spreadsheet 1 and Spreadsheet 2.

Spreadsheet 1 has a list of partial employee names in column A.
Spreadsheet 2 has a list of 500,0000 full employee names in column A and their phone number in column B and address in column C through E.

Basically what I want to do is do a wildcard search for the partial employee name, so like lookup Spreadsheet 1' Column A's *name* in column A of Spreadsheet 2. Based on the number of matches. I want to insert that many blank rows underneath the partial employee name, and paste those matched rows there, then continue to the second partial employee name lookup and repeat the process.

This loop has to repeat 1000 times.

I would appreciate help very much.

Post a workbook with a useful amount of DUMMY data.

Thank you for taking the time to respond to me once again, it is most appreciated. I have attached the spreadsheet. Sheet 3 shows how I want the data to look using the partial names from spreadsheet 1. I made a slight adjustment, where I would like in the output in sheet 3 ,the partial employee name next to each row of data that is extracted from sheet 2 (which is associated to that partial name), this row consists of about 7 or 8 cells if that makes it easier. I think it will be clearer if you look at the spreadsheet.

Thanks again.

Try this -- code goes in the Sheet1 module.

Option Explicit

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
                rFind.EntireRow.Copy
                rTest(iRow).Offset(1).Insert
                Set rFind = rLook.Find(What:=rTest(iRow).Text, After:=rFind, _
                                       SearchDirection:=xlPrevious)
            Loop Until rFind.Address = sAddr
            
        End If
    Next iRow
End Sub

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

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

    Application.ScreenUpdating = False
    
    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 = False
    Application.ScreenUpdating = True
End Sub

Add a row above and a column to the left of your data on sheet2.

Sub x()
    Dim cell       As Range
    Dim rData       As Range

    With Sheet2
        .AutoFilterMode = False
        Set rData = .Range("A1", .Cells(.Rows.Count, "H").End(xlUp))
    End With
    
    Sheet3.UsedRange.ClearContents
    Application.ScreenUpdating = False
    
    For Each cell In Me.Range("A1", Me.Cells(Me.Rows.Count, "A").End(xlUp))
        Sheet2.AutoFilterMode = False
        rData.Columns(1).Value = cell.Text
        rData.AutoFilter Field:=2, Criteria1:="*" & cell.Text & "*"
        rData.Offset(1).Copy Destination:=Sheet3.Cells(Rows.Count, "A").End(xlUp).Offset(1)
    Next cell
    
    Sheet2.AutoFilterMode = False
    rData.Columns(1).ClearContents
    Sheet3.Columns.AutoFit
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub