Rechercher plusieurs lignes

Private Sub Worksheet_Change(ByVal Target As Range)
Dim dl As Long 'déclare la variable dl (Dernière Ligne)
Dim pl As Range 'déclare la variable pl (PLage)
Dim cel As Range 'déclare la variable cel (CELlule)
Dim dest As Range 'déclare la variable dest (cellule de DESTination)
Dim cod As String 'déclare la variable cod (CODe)
Dim r As Range 'déclare la variable r (Recherche)
Dim pa As String 'déclare la variable pa (Première Adresse)

If Target.Address <> "$O$1" Then Exit Sub 'si le changement a lieu ailleurs que dans la cellule O1, sort de la procédure
If Selection.Cells.Count > 1 Then Exit Sub 'si plus d'une seule cellule est sélectionnée, sort de la procédure
Sheets("Feuil2").Range("A1").CurrentRegion.Clear 'efface la plage de cellules contiguës à A1 de l'onglet "Feuil2"
With Sheets("Feuil1") 'prend en compte l'onglet "Feuil1" (à adapter à ton cas)
    dl = .Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne dl de la colonne A
    Set pl = .Range("A2:A" & dl) 'définit la plage pl
End With 'fin de la prise en compte de l'onglet "Feuil1"
cod = CStr(Target.Value) 'définit la variable cod
Set r = pl.Find(cod, , xlValues, xlWhole) 'définit la recherche r
If Not r Is Nothing Then 'condition : si il existe au moins une occurrence
    pa = r.Address 'définit la première adresse trouvée
    Do 'exécute
        With Sheets("Feuil2") 'prend en compte l'onglet "Feuil2" (à adapter à ton cas)
            'définit la cellule de destination
            Set dest = IIf(.Range("A1").Value = "", .Range("A1"), .Cells(Application.Rows.Count, 1).End(xlUp).Offset(1, 0))
        End With 'fin de la prise en compte de l'onglet "Feuil2"
        Rows(r.Row).Copy dest 'copy et colle la ligne de l'occurrence trouvée dans dest
        Set r = pl.FindNext(r) 'redéfinit la recherche R (occurrence suivante)
    Loop While Not r Is Nothing And r.Address <> pa 'boucle tant qu'il exite de nouvelles occurrences ailleurs qu'en pa
End If 'fin de la condition
End Sub