Création base de données à partir de fichiers multiples

Mettre les classeurs en 1 "zip" sans données confidentielles en pièce jointe sur https://www.cjoint.com/
et coller le raccourci  proposé (clic droit) dans le message de réponse 

Sub recup_infos()
    Dim TInfos, derlig, Fichier, rep
    
    rep = "D:\Déchets\Enlèvements\"
    Application.ScreenUpdating = False      'fige ecran
    Set WBT = Workbooks.Open("D:\Déchets\Modele_Total.xlsx")    'ouverture model
    With WBT.Worksheets("feuil1")
        derlig = .Cells.Find("*", , , , xlByRows, xlPrevious).Row       'derniere cellule non vide feuil1
        If derlig < 6 Then derlig = 6       'pas effacer entete si vide
        .Range("A6:J" & derlig).ClearContents       'efface derniere recup
    End With
    Fichier = Dir(rep & "Enlèvement*.xlsx")     'premier fichier
    If Fichier <> Empty Then        'fichier existe
        Do
            Workbooks.Open rep & Fichier    'ouverture fichier
            TInfos = ActiveWorkbook.Worksheets("Sheet1").Range("A6:I30").Value  'mise en memoire plage
            ActiveWorkbook.Close False      'fermeture fichier sans sauvegarde
            'edriture fichier model
            With WBT.Worksheets("feuil1")
                derlig = .Range("A" & Rows.Count).End(xlUp).Row + 1  'derniere cellule non vide +1 colonne A
                If derlig < 6 Then derlig = 6       ' si vide pour premier fichier
                .Range("A" & derlig & ":I" & derlig + 24) = TInfos      'restitution infos
                .Range("J" & derlig) = Fichier                                   'nom du fichier recupere
            End With
            Fichier = Dir       'fichier suivant
        Loop Until Fichier = Empty      'boucle jusqu'a plus de fichier
        WBT.SaveAs ("D:\Déchets\Total_" & Year(Date) & ".xlsx")     'sauvegarde avec annee en cours
        WBT.Close       'fermeture
    Else
        MsgBox "Pas de fichier dans ce repertoire: " & rep
        WBT.Close
        Exit Sub
    End If
    Application.ScreenUpdating = True
    
    MsgBox "Recuperation Ok"
End Sub

Option Explicit

Sub ImporterDonnees()
Dim objShell As Object, objFolder As Object
Dim Chemin As String, fichier As String

Application.ScreenUpdating = False
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&)
If objFolder Is Nothing Then
   MsgBox "Abandon opérateur", vbCritical, "Annulation"
Else
   Cells.ClearContents
   Chemin = objFolder.ParentFolder.ParseName(objFolder.Title).Path & "\"
   fichier = Dir(Chemin & "*.xls")
   Do While Len(fichier) > 0
      If fichier <> ThisWorkbook.Name Then
         ThisWorkbook.Names.Add "Plage", RefersTo:="='" & Chemin & "[" & fichier & "]Sheet1'!$A$6:$I$30"
         With Sheets("Feuil2")
            .[A6:I30] = "=Plage"
            .[A6:I30].Copy
            Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(2, 0).PasteSpecial xlPasteValues
            Sheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Offset(0, 10) = fichier
         End With
      End If
      fichier = Dir()
   Loop
   ThisWorkbook.Names("Plage").Delete
   [A1].Select
End If
End Sub