Copiez les toutes valeurs d'une requête SQL dans un classeur

Bonjour,

J'ai une requête SQL à l'intérieur d'une macro qui cherche la valeur d'un classeur ouvert à l'intérieur d'un classeur fermé. Lorsqu'une ou des valeurs sont trouvées dans le classeur fermé, il copie toutes les valeurs dans le fichier actif alors, j'ai un "ComboBox" qui s'ouvre avec toutes les valeurs trouvées pour que puisse choisir la valeur à copier dans la première cellule du classeur actif. 

J'essais de le modifier, mais sans succès, pour qu'il copie toutes les valeurs sans écraser les valeurs du tableau actif.Je veux enlever le ComboBox qui ne me servira plus dans ce cas là. Exemple: j'ai une valeur en "A2" qui est cherchée dans le classeur fermé et j'ai deux correspondances. Je voudrais remplacer la première valeur en "A2" et copier la ligne "2", en insérer nouvelle ligne pour insérer la deuxième valeur en "A3".

Voici donc le code:

Public T_NT As String
Sub Recherche_Classeur_Ferme()
    Dim Cn As Object
    Dim Rst As Object 'Comparaison des deux fichiers
    Dim Fichier_tester, texte_SQL As String
    Dim NomFeuille As String
    Dim i, Derlig As Integer
    
        '-----------------------------
        Derlig = ActiveSheet.Range("B" & Rows.Count).End(xlUp).Row
        For i = 2 To Derlig
        With Worksheets(2)
            Sondage = .Cells(i, 2).Value
        End With
        'Définit le classeur fermé servant de base de données
        Fichier_tester = "T:\Geotechnique\Mouvements\Entrepot\BDFS\0_Sondages_a_saisir_Geotec\" & "SONDAGE.xlsx" '"M:\Entrepot\BDFS\0_Sondages_a_saisir_Geotec\" & "SONDAGE.xlsx"
        'Nom de la feuille dans le classeur fermé
        Table = "SONDAGE" & "$"
        plage = "B2:B100000"
        Champ = "NO_SONDAGE"
        '--- Connexion ---
        Set Cn = CreateObject("ADODB.connection")
        With Cn
            .Provider = "Microsoft.Jet.OLEDB.4.0"
            .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
             & Fichier_tester & ";Extended Properties=""Excel 12.0;HDR=YES;"""
            .Open
        End With
        '-----------------
        '... la requête avec WHERE et LIKE
        texte_SQL = "SELECT " & Champ & " FROM [" & Table & "] WHERE " & Champ & " like '" & "%" & Sondage & "%';" ''" & Sondage & "%';"
        Set Rst = CreateObject("ADODB.Recordset")
        Rst.Open texte_SQL, Cn, adOpenStatic
        'Ecriture dans la feuille de calcul
        If Not Rst.EOF Then
            ActiveSheet.Cells(i, 7).CopyFromRecordset Rst
            Rst.MoveFirst
            tsondage = Rst.GetRows
            Nb = UBound(tsondage, 2)
            If Nb > 0 Then
                TS = "["
                For NS = 0 To Nb: TS = TS & tsondage(0, NS) & " ¤ ": Next NS
                    If NS >= 2 Then
                        UserForm3.Show
                        ActiveSheet.Cells(i, 2) = UserForm3.ComboBox1.Value
                        UserForm3.ComboBox1.Clear
                    Else
                        TS = Left(TS, Len(TS) - 3) & "]"
                        T_NT = T_NT & vbNewLine & Sondage & " en " & Nb + 1 & " exemplaires " & vbNewLine & TS
                    End If
            End If
        Else
            'Infos non trouvees
            T_NT = T_NT & vbNewLine & Sondage
        End If
        '--- Fermeture connexion ---
        Cn.Close
        Set Cn = Nothing
        Next i
End Sub

Je vais vous envoyé une image de la mise en forme de mon classeur.

Merci pour voter aide!

Windows / Chrome 103.0.0.0