Combiner des fichier Excel de plusieurs répertoires

Bonjour le forum

Je me tourne vers vous pour trouver un code qui , je suis sûr, doit déjà exister, mais mes recherches n'aboutissent pas dans mon sens

Je suis à la recherche d'un code qui me permettrait suite à la sélection d'un dossier, de rassembler dans même et unique fichier excel tous les fichiers s'y trouvant même si ils sont rangé dans des sous dossier .

Pour info dans ce répertoire, il y a autant de sous dossiers que de fichiers excel, ceux-ci ne portent pas le même nom et si je pouvais savoir combien il y a de sous dossier et de fichiers rassembler cela me permettrait de pouvoir vérifier qu'il ne me manque pas de fichier excel.

D'avance je vous remercie pour votre aide et votre disponibilité.

Bonjour,

Rassembler comment ? juste la liste ou le contenu ?

Bonsoir Steelson

Merci pour ta disponibilité et pour ton aide

Chaque fichier excel contenu dans les sous répertoires contient la même feuille mais avec des données différentes

Mon but est de pouvoir rassembler les onglets de chaque fichiers excel en un seul mais maintenant que tu me pose la question je ne m'étais pas rendu compte du nommage de mes onglet

Pour bien faire il faudrait du coup importer l'onglet unique de chaqu'un de fichier excel contenu dans les sous-dossiers de mon répertoire en les nommant avec le nom du sous-dossier ou en supprimant "ExportComac" dans le nommage des onglets si on prend le nom du fichier excel

j'ai déposé un exemple

A savoir aussi dans chaque sous-répertoires il y a d'autre fichiers mais jamais d'autre excel

Voici

Option Explicit
    Dim destinataire As Workbook

Sub compiler()
    Dim MonRepertoire As String
    Dim Repertoire As FileDialog
    Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
    Repertoire.Show
    If Repertoire.SelectedItems.Count = 0 Then Exit Sub
    MonRepertoire = Repertoire.SelectedItems(1)
    Set destinataire = ActiveWorkbook
    ListeFichiers MonRepertoire

End Sub
Sub ListeFichiers(Repertoire As String)

    Dim onglet As String
    Dim Fso, SourceFolder, SubFolder, fichier As Object
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Set SourceFolder = Fso.GetFolder(Repertoire)

    ' boucle sur tous les fichiers du répertoire
    For Each fichier In SourceFolder.Files
        If Right(fichier.Name, 5) = ".xlsx" Then
            If Left(fichier.Name, 2) <> "~$" Then

                Sheets.Add After:=ActiveWorkbook.Worksheets(Worksheets.Count)
                ' ouverture du fichier
                Workbooks.Open Filename:=Repertoire & "\" & fichier.Name
                onglet = Range("B1").Value
                Cells.Copy
                ' retour fichier principal
                destinataire.Activate
                ActiveSheet.Paste
                Application.CutCopyMode = False
                On Error Resume Next
                    ActiveSheet.Name = onglet
                On Error GoTo 0
                ' ferme le fichier sans faire de changement
                Windows(fichier.Name).Activate
                ActiveWindow.Close

            End If
        End If
    Next fichier

    ' appel récursif pour les sous-répertoires
    For Each SubFolder In SourceFolder.subfolders
        ListeFichiers SubFolder.Path
    Next SubFolder

End Sub

Bonsoir le forum

Bonsoir Steelson

C'est juste parfait, pile polie ce dont j'avais besoin

Je te remercie pour ton aide et ta disponibilité en ce Week-end

Vraiment un grand merci