Regrouper plusieurs fichiers excel en un seul

Public Sub Regrouper_Fichiers()
' regroupe dans les colonnes de la feuille 1 d'un fichier,
' la colonne A de chaque fichier excel d'un répertoire.
'
Dim fso As Object               'Système de fichiers
Dim rep As Object               'Répertoire
Dim cfr As Object               'Collection de fichiers du répertoire
Dim fic As Object               'Fichier (élément de la collection cfr)
Dim wbk As Workbook             'Classeur
Dim res As Workbook             'Classeur resultat
Dim rng As Range                'Plage de cellules
Dim dst As Range                'Cellule de destination
Dim pth As String               'Chemin du répertoire

' Définir le répertoire à lire
pth = "D:\TEMP"
' Créer le fichier résultat
Set res = Workbooks.Add(xlWBATWorksheet)
Set dst = res.Worksheets(1).Range("A1")
' Lecture du répertoire
Set fso = CreateObject("Scripting.FileSystemObject")
Set rep = fso.GetFolder(pth)
Set cfr = rep.Files
' Contrôler chaque fichier du répertoire
For Each fic In cfr
  ' - Vérifier s'il s'agit d'un fichier Excel...
  If StrComp(fso.GetExtensionName(fic.Name), "xlsx", vbTextCompare) = 0 Then
    ' ... dans l'affirmative, ouvrir le fichier et mettre à jour les liaisons
    Set wbk = Workbooks.Open(Filename:=pth & "\" & fic.Name, UpdateLinks:=xlUpdateLinksAlways)
    ' Placer le nom du fichier en titre de colonne résultat
    dst.Value = fic.Name
    ' Copier la colonne en dessous
    Set rng = wbk.Worksheets(1).UsedRange.Columns(1)
    rng.Copy dst.Offset(1)
    ' Fermer le fichier sans le modifier
    wbk.Close False
    ' Destination sur colonne suivante
    Set dst = dst.Offset(0, 1)
  End If
Next fic

End Sub