Faire une recherche de plusieurs valeurs avec saut de cellule

Public o As String 'déclare la variable o (Ouverture)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Column <> 1 Then Exit Sub 'si le double-clic est fait ailleurs que dans la colonne A, sort de la procédure
Cancel = True 'évite le mode édition lié au double-clic
o = Target.Value 'définit la variable o (déclarée publique dans le module1)
If o <> "" Then UserForm1.Show 'si o n'est pas vide, affiche l'UserForm1
End Sub

Private Sub UserForm_Initialize() 'à l'initialisation de l'UserForm
Dim r As Range 'déclare la variable r (Recherche)
Dim pa As String 'déclare la variable pa (Première Adresse)
 
With Sheets("Traversants").Columns(1) 'prend en compte la colonne A de l'onglet "Traversants"
    Set r = .Find(o, , xlValues, xlWhole) 'définit la recherche r (recherche l'ouverture o dans la colonne A de l'onglet "Traversants")
    If Not r Is Nothing Then 'condition : si il existe au moins une occurrence de o
        pa = r.Address 'définit la première adresse de l'occurrence trouvée
        Do 'exécute
            Me.ListBox1.AddItem r.Offset(0, 1).Value 'ajoute le tuyau à la ListBox1
            Set r = .FindNext(r) 'redéfinit la recherche r (cherche l'occurrence suivante)
        Loop While Not r Is Nothing And r.Address <> pa 'boucle tant qu'il existe des occurrence de o ailleurs qu'en pa
    End If 'fin de la condition
End With 'fin de la prise en compte de la colonne A de l'onglet "Traversants"
End Sub
 
 
Private Sub CommandButton2_Click() 'bouton "Ok"
Dim x As Integer
ActiveCell.Offset(0, 1).Value = Me.ListBox1.List(0)
If Me.ListBox1.ListCount > 1 Then
    For x = 1 To Me.ListBox1.ListCount - 1
        ActiveCell.Offset(x, 0).EntireRow.Insert
        ActiveCell.Offset(x, 1).Value = Me.ListBox1.List(x)
    Next x
End If
Unload Me 'vide et ferme l'UserForm1
End Sub
 
 
Private Sub CommandButton1_Click() 'bouton "Exit"
Unload Me 'vide et ferme l'UserForm1
End Sub

Public Sub recup()
Dim dl As Integer 'déclare la variable dl (Dernière Ligne)
Dim i As Integer 'déclare la variable i (incrément de ligne)
Dim r As Range 'déclare la variable r (Recherche)
Dim pa As String 'déclare la variable pa (Première Adresse)
Dim tt() As String 'déclare le tableau de variables tt (Tableau des Traversants)
Dim x As Integer 'déclare la variable x (incrément de variable)
Dim y As Integer 'déclare la variable y (incrément ligne)
 
dl = Cells(Application.Rows.Count, 1).End(xlUp).Row 'définit la dernière ligne
For i = dl To 3 Step -1 'boucle 1 inversée : sur toutes les cellules éditées cel de la colonne A (de la dernière à la ligne 3)
    With Sheets("Traversants").Columns(1) 'prend en compte la colonne A de l'onglet "Traversants"
        Set r = .Find(Cells(i, 1).Value, , xlValues, xlWhole) 'définit la recherche r (recherche l'ouverture o dans la colonne A de l'onglet "Traversants")
        If Not r Is Nothing Then 'condition : si il existe au moins une occurrence de o
            pa = r.Address 'définit la première adresse de l'occurrence trouvée
            Do 'exécute
                ReDim Preserve tt(x) 'redimensionne le tableau de variables tt
                tt(x) = r.Offset(0, 1).Value 'ajoute une variable au tableau de variables tt
                Set r = .FindNext(r) 'redéfinit la recherche r (cherche l'occurrence suivante)
                x = x + 1 'incrémente x
            Loop While Not r Is Nothing And r.Address <> pa 'boucle tant qu'il existe des occurrence de o ailleurs qu'en pa
        End If 'fin de la condition
    End With 'fin de la prise en compte de la colonne A de l'onglet "Traversants"
    Cells(i, 2).Value = tt(0) 'place la première variable dans la cellule de la colonne B
    If UBound(tt) > 1 Then 'condition : si le nombres de variable est supérieur à 1
        For y = 1 To UBound(tt) 'boucle 2 : de 1 au nombre de variables -1
            Rows(i + y).EntireRow.Insert 'rajoute une ligne
            Cells(i + y, 2).Value = tt(y) 'place le traversant en colonne B de la ligne rajoutée
        Next y 'prochaine variable de la boucle 2
    End If 'fin de la condition
    Erase tt
    x = 0
Next i 'prochaine cellule cel de la boucle 1
End Sub

Private Sub CommandButton1_Click() 'bouton "Récup"
Module1.recup 'lance la procédure "recup" du module1
End Sub