Copying all instances of a row match to another sheet

The below code copies over a row from Sheet1 that contains a certain criteria (input via msgbox) to Sheet2. Every time it's run, it will stack these rows into Sheet2, one after the other, without overwriting anything.

I love this macro. It works perfectly for me...except for one problem. It only copies over one instance of each match. I would like it to copy over all instances - multiple rows if they exist. How can I do this?

I would prefer not start over with a new code unless necessary.

Thanks!

Sub FindAndCopyEmailAddress()

Dim vnt_Input As Variant
Dim rng_Found As Excel.Range
Dim wks1 As Excel.Worksheet, wks2 As Excel.Worksheet
Dim rng_target As Excel.Range
Dim l_FreeRow As Long

On Error Resume Next
Set wks1 = ThisWorkbook.Worksheets("Sheet1")
Set wks2 = ThisWorkbook.Worksheets("Sheet2")

On Error GoTo ErrorHandler

If wks1 Is Nothing Or wks2 Is Nothing Then
    Err.Raise vbObjectError + 20000, , "Cannot find sheet1 or 2"
End If

vnt_Input = InputBox("Please enter the address that you're looking for", "Address Copier")

If vnt_Input = "" Then GoTo ExitPoint

Set rng_Found = wks1.Cells.Find(What:=vnt_Input, After:=ActiveCell, _
 LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
 SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

If rng_Found Is Nothing Then
    MsgBox "Cannot find that address."
    GoTo ExitPoint
End If

l_FreeRow = wks2.UsedRange.Row + wks2.UsedRange.Rows.Count

If l_FreeRow > wks2.Rows.Count Then
    Err.Raise vbObjectError + 20000, , "No free rows on sheet " & wks2.Name
End If

Set rng_target = wks2.Cells(l_FreeRow, 1)

rng_Found.EntireRow.Copy rng_target

ExitPoint:

On Error Resume Next
Set rng_Found = Nothing
Set wks1 = Nothing
Set wks2 = Nothing
Set rng_target = Nothing
On Error GoTo 0

Exit Sub

ErrorHandler:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description

Resume ExitPoint

End Sub