Regrouper des classeurs avec un onglet par classeur

Sub lister()
Dim monFichier As String
Dim wb As Workbook
Dim chemin As String
Set wb = Workbooks(ThisWorkbook.Name) 'classeur reception
' On a besoin du chemin absolu du dossier
' Doit se terminer par \
chemin = ThisWorkbook.Path & "\"
' La fonction Dir(chemin, mode) permet de parcourir un dossier
' Ici je rajoute à mon chemin "*.xlsx",
' pour ne retrouver que mes fichiers Excel
' vbNormal permet de ne récupérer que des fichiers,
' vbDirectory récupère tout (dossiers et fichiers)
monFichier = Dir(chemin & "*.xlsx", vbNormal)
Do While monFichier <> ""
   wb.Sheets.Add(After:=Worksheets(Worksheets.Count)).Name = Split(monFichier, ".")(0) 'ajoute un onglet et le renomme
RequeteClasseurFerme (chemin & monFichier)
' Permet de passer au fichier suivant
monFichier = Dir
Loop
End Sub
'https://silkyroad.developpez.com/VBA/ClasseursFermes/
'https://silkyroad.developpez.com/VBA/ClasseursFermes/#LV
   'Nécéssite d'activer la référence Microsoft ADO ext x.x for DLL and Security
   'Vous devez préalablement activer la référence Microsoft ActiveX Data Objects x.x Library pour utiliser les exemples présentés dans ce tutoriel.
  Sub RequeteClasseurFerme(ByVal chemin As String)
    Dim Cn As ADODB.Connection
    Dim NomFeuille As String, texte_SQL As String
    Dim Rst As ADODB.Recordset
    Dim oCat As ADOX.Catalog
    Dim Resultat As String
    Dim Feuille As ADOX.Table
    
    Set Cn = New ADODB.Connection
    Set oCat = New ADOX.Catalog
    
    With Cn
        .Provider = "Microsoft.Jet.OLEDB.4.0"
        .ConnectionString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" _
            & chemin & ";Extended Properties=""Excel 12.0;HDR=YES;"""
        .Open
    End With
    
    Set oCat.ActiveConnection = Cn
        
    For Each Feuille In oCat.Tables
        Resultat = Feuille.Name
    Next
    
    'Nom de la feuille dans le classeur fermé
    NomFeuille = Resultat
    
    'Définit la requête.
    '/!\ Attention à ne pas oublier le symbole $ après le nom de la feuille.
    texte_SQL = "SELECT * FROM [" & NomFeuille & "]"
    
    Set Rst = New ADODB.Recordset
    Set Rst = Cn.Execute(texte_SQL)
    
    'Ecrit le résultat de la requête dans la cellule A1
    Range("A1").CopyFromRecordset Rst
    
    '--- Fermeture connexion ---
     Set Feuille = Nothing
    Set oCat = Nothing
    Cn.Close
    Set Cn = Nothing
End Sub