Regrouper plusieurs fichiers excel en un seul

Résolu/Fermé
solene77 - 13 juin 2018 à 13:27
 Gabish - 18 avril 2019 à 20:14
Bonjour,

J'ai une centaine de fichiers excel constitué d'uns seule colonne de données.
Et je souhaiterais les regrouper en un seul fichier excel, sans passer par la fonction copier/coller.

Que faire ?
Merci de votre aide.



A voir également:

10 réponses

Patrice33740
Messages postés
8549
Date d'inscription
dimanche 13 juin 2010
Statut
Membre
Dernière intervention
7 mai 2022
1 751
13 juin 2018 à 15:12
Bonjour,

Sans passer par copier/coller c'est une difficulté supplémentaire inutile,
donc voici une macro avec des copier/ coller (adapter le nom du répertoire) :
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
Si tes fichiers sont au format xls au lieu de xlsx, corriges la ligne 27

3