Sub hhh()
i =  2 
Dim hh As String
hh = ""
While ThisWorkbook.Sheets( 3 ).Cells(i,  1 ) <> ""

hh = ThisWorkbook.Sheets( 3 ).Cells(i,  3 ).Text
    Sheets( 2 ).Select
    Range(Cells( 2 ,  6 ), Cells( 23667 ,  6 )).Select
    On Error GoTo  1 
        Selection.Find(What:=hh, After:=ActiveCell, LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False).Select

        r = ActiveCell.Row
        s = ActiveCell.Column
        If r =  1  And s =  1  Then GoTo  3 
        Range(Cells(r,  1 ), Cells(r,  6 )).Select
        Selection.Copy Destination:=aa
        Sheets( 3 ).Select

        Cells(i,  4 ).Select
        ActiveSheet.Paste
        
        GoTo  3 

 1 :
Cells( 1 ,  1 ).Select
Resume Next

 3 :
i = i +  1 
Wend
End Sub