Option Explicit
Sub test()
Dim wsSource As Worksheet
Dim wsTarget As Worksheet
Dim strFind As String
Dim rowCopy As Long
Dim rowPaste As Long
Dim i As Long
Dim lr As Long
Dim strFoundAddress As String
Dim rngFound As Range
Dim strId As String
Dim lngId As Long
Set wsTarget = Sheets("Sheet1")
Set wsSource = Sheets("Sheet2")
'get the last row
lr = wsTarget.Range("A" & Rows.Count).End(xlUp).Row
rowPaste = lr
For i = 10 To lr
With wsTarget
lngId = .Range("A" & i).Value 'eg 1, 2, 3, etc
strId = .Range("B" & i).Value 'eg AR145....
strFind = wsTarget.Range("C" & i).Value 'eg EFAR.....
End With
With wsSource.Range("A2:D10")
Set rngFound = .Find(strFind, LookIn:=xlValues)
If Not rngFound Is Nothing Then
strFoundAddress = rngFound.Address
Do
rowCopy = rngFound.Row
'was the string found?
If rowCopy <> 0 Then
rowPaste = rowPaste + 1
'copy and paste
wsTarget.Range("A" & rowPaste).Value = lngId
wsTarget.Range("B" & rowPaste).Value = strId
wsSource.Range("C" & rowCopy & ":D" & rowCopy).Copy _
Destination:=wsTarget.Range("C" & rowPaste)
End If
If Not rngFound Is Nothing Then
Set rngFound = .FindNext(rngFound)
End If
Loop While Not rngFound Is Nothing And rngFound.Address <> strFoundAddress
End If
End With
Next i
'sort the output
wsTarget.Range("A10").Sort _
Key1:=wsTarget.Columns("A"), _
Header:=xlGuess
'tidy up
Set wsSource = Nothing
Set wsTarget = Nothing
Set rngFound = Nothing
End Sub