Fusionner plusieurs fichiers excel en un seul

adeza74 Messages postés 6 Date d'inscription Statut Membre Dernière intervention -
adeza74 Messages postés 6 Date d'inscription Statut Membre Dernière intervention - 11 juin 2019 à 12:26

Bonjour,
Je souhaite fusionner via une macro 12 fichiers excel qui ont tous la même structure (même ligne d'entête en ligne 1 et même nombre de colonnes).
Ils sont dans un répertoire "fichiers source".
Le fichier fusionné, à créer, se trouvera dans le répertoire "fichier fusionné". Au même niveau que "fichiers source".
Plus précisement, j'aimerais que:
1. on copie la ligne d'entête en permière ligne du fichier fusionné (une seule fois)
2. on mette le nom du fichier source en dernière colonne, à chaque ligne
Merci pour votre aide!

A voir également:

Fusionner plusieurs fichiers excel en un seul vba
Renommer plusieurs fichiers en même temps - Guide
Liste déroulante excel - Guide
Fusionner plusieurs feuilles excel en une seule - Guide
Formule moyenne excel plusieurs colonnes - Guide
Comment réduire la taille d'un fichier - Guide

2 réponses

Réponse 1 / 2

f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention 1 713

Bonjour,

Peu importe l'ordre de recuperation fichier???

adeza74 Messages postés 6 Date d'inscription Statut Membre Dernière intervention 1

Bonjour,
Oui tant que le nom du fichier est recopié à chaque ligne.
Merci.

f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention 1 713

Bonjour,

Vous connaisez le VBA Excel ou pas ??

un exemple de code:

Sub Fusion_Fichiers()
    Dim WBD As Workbook
    
    Application.ScreenUpdating = False
    Set WBD = ThisWorkbook      'fichier destinataire
    WBD.ActiveSheet.Cells.ClearContents     'efface contenu feuille active, a voir pour nom de feuille
    Chemin_Fichier = ThisWorkbook.Path & "\"
    Fichier = Dir(Chemin_Fichier & "*.xlsx")    'premier fichier si existe
    If Fichier <> "" Then
        NbF = 1
        Do While Fichier <> ""
            If NbF = 1 Then
                CLD = "$A$1"        'cellules titre colonnes pour copie
            Else
                CLD = "$A$2"        'cellules sans titre pour copie
            End If
            Workbooks.Open Chemin_Fichier & Fichier     'ouverture fichier
                With ActiveSheet
                    Plage = .UsedRange.Address
                    TAdr = Split(Plage, ":")
                    Derl = WBD.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row     'derniere  cellule non vide colonne A
                    If Derl > 1 Then Derl = Derl + 1
                    .Range(CLD & ":" & TAdr(1)).Copy WBD.ActiveSheet.Range("A" & Derl)
                    With WBD.ActiveSheet
                        PCV = .Range("A" & Rows.Count).End(xlUp).Row + 1    'premiere cellule vide colonne A
                        .Range("A" & PCV) = Fichier     'ecriture nom de fichier
                    End With
                End With
            Workbooks(Fichier).Close False      'fermeture fichier source sans sauvegarde
            Fichier = Dir       'fichier suivant si existe
            NbF = NbF + 1       '
        Loop
    Else
        MsgBox "Aucun Fichier trouve!!", vbCritical, "Annulation"
    End If
    Application.ScreenUpdating = True
End Sub

adeza74 Messages postés 6 Date d'inscription Statut Membre Dernière intervention 1

Merci f894009 et mes excuses pour ma réponse tardive, j'étais en déplacement et ne pouvais tester votre proposition.
Je connais un peu VBA mais là je suis bloqué avec un message d'erreur au niveau de chaque variable qui n'a pas été déclarée.
Et je ne sais pas si j'ai raison de les déclarer en Characteres en Integer ou...

Réponse 2 / 2

adeza74 Messages postés 6 Date d'inscription Statut Membre Dernière intervention 1

Autre possibilité, j'ai ce code qui marche très bien pour fusionner les fichiers mais je ne suis pas parvenu à le modifier pour que:
1. on copie la ligne d'entête en permière ligne du fichier fusionné (une seule fois)
2. on mette le nom du fichier source en dernière colonne, à chaque ligne

Voilà le code:

Sub CollecterDataDesClasseurs()
Dim wbci As Workbook, wbso As Workbook
Dim shac As Worksheet
Dim deli As Integer, li As Integer, lici As Long 'Avant lici As Integer
Dim rep As String, dosA As String, dosB As String
Dim nclb As String, nclc As String, coci As String
li = Cells(Rows.Count, 1).End(xlUp).Row + 1
rep = Range("repbas"): dosA = Range("claco"): dosB = Range("clafi")
Set shac = ActiveSheet
' récupérer et ouvrir le classeur de collecte
Application.ScreenUpdating = False
nclb = Dir(rep & "\" & dosA & "\*.*")
Set wbci = Workbooks.Open(rep & "\" & dosA & "\" & nclb)
lici = wbci.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Row + 1
'adresse de la dernière colonne
coci = Split(Cells(1, wbci.Sheets(1).Cells(1, Columns.Count).End(xlToLeft).Column).Address, "$")(1)
' pointer sur répertoire des classeurs à traiter CD....
nclc = Dir(rep & "\" & dosB & "\*.*")
Do While nclc <> ""
Set wbso = Workbooks.Open(rep & "\" & dosB & "\" & nclc)
With wbso.Sheets(1)
deli = .Cells(Rows.Count, 1).End(xlUp).Row
.Range("A2:" & coci & deli).Copy Destination:=wbci.Sheets(1).Range("A" & lici)
lici = lici + deli - 1
End With
shac.Cells(li, 1) = nclc
shac.Cells(li, 2) = deli - 1
li = li + 1
wbso.Close
nclc = Dir ' suivant
Loop
MsgBox "Data are copied in the workbook : " & wbci.Name & Chr(10) & "which is located here: " & dosA
wbci.Close SaveChanges:=True
Set wbso = Nothing: Set wbci = Nothing: Set shac = Nothing
Application.ScreenUpdating = True
End Sub

f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention 1 713

Bonjour,

Le code que vous presentez fait a priori la meme chose pour la partie recherche et copie

Et je ne sais pas si j'ai raison de les déclarer en Characteres en Integer ou...

code avec ecriture nom de fichier a chaque ligne de copie du fichier, "mon" code precedent copiait le nom a la fin de chaque copie

Sub Fusion_Fichiers()
    Dim WBD As Workbook
    '
    Dim Chemin_Fichier As String
    Dim Fichier As String
    Dim CLD As String
    Dim Plage As String
    Dim ColNF As String
    '
    Dim TAdr As Variant
    Dim ColF As Variant
    '
    Dim Derl As Long
    Dim NbF As Long
    Dim PCV As Long
    Dim Of7 As Long
    Dim LM As Long
    
    Application.ScreenUpdating = False
    Set WBD = ThisWorkbook      'fichier destinataire
    WBD.ActiveSheet.Cells.ClearContents     'efface contenu feuille active, a voir pour nom de feuille
    Chemin_Fichier = ThisWorkbook.Path & "\"
    Fichier = Dir(Chemin_Fichier & "*.xlsx")    'premier fichier si existe
    If Fichier <> "" Then
        NbF = 1
        Do While Fichier <> ""
            If NbF = 1 Then
                CLD = "$A$1"        'cellules titre colonnes pour copie
                Of7 = 1                 'offset ligne de depart
                LM = 1                  'offset ligne de fin
            Else
                CLD = "$A$2"        'cellules sans titre pour copie
                Of7 = 0
                LM = 2
            End If
            Workbooks.Open Chemin_Fichier & Fichier     'ouverture fichier
                With ActiveSheet
                    Plage = .UsedRange.Address
                    TAdr = Split(Plage, ":")
                    ColF = Split(TAdr(1), "$")
                    ColNF = Chr(Asc(ColF(1)) + 1)       'colonne pour nom de fichier
                    LF = CLng(ColF(2)) - LM                 'nb ligne du fichier source
                    Derl = WBD.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row     'derniere  cellule non vide colonne A
                    If Derl > 1 Then Derl = Derl + 1
                    .Range(CLD & ":" & TAdr(1)).Copy WBD.ActiveSheet.Range("A" & Derl)
                    For n = Derl + Of7 To Derl + LF
                        WBD.ActiveSheet.Range(ColNF & n) = Fichier      ' ecriture nom du fichier
                    Next n
                End With
            Workbooks(Fichier).Close False      'fermeture fichier source sans sauvegarde
            Fichier = Dir       'fichier suivant si existe
            NbF = NbF + 1       '
        Loop
    Else
        MsgBox "Aucun Fichier trouve!!", vbCritical, "Annulation"
    End If
    Application.ScreenUpdating = True
End Sub

f894009 Messages postés 17277 Date d'inscription Statut Membre Dernière intervention 1 713

Bonjour,

Code sans boucle pour nom de fichier

Sub Fusion_Fichiers()
    Dim WBD As Workbook
    '
    Dim Chemin_Fichier As String
    Dim Fichier As String
    Dim CLD As String
    Dim Plage As String
    Dim ColNF As String
    '
    Dim TAdr As Variant
    Dim ColF As Variant
    '
    Dim Derl As Long
    Dim NbF As Long
    Dim PCV As Long
    Dim Of7 As Long
    Dim LM As Long
    
    Application.ScreenUpdating = False
    Set WBD = ThisWorkbook      'fichier destinataire
    WBD.ActiveSheet.Cells.ClearContents     'efface contenu feuille active, a voir pour nom de feuille
    Chemin_Fichier = ThisWorkbook.Path & "\"
    Fichier = Dir(Chemin_Fichier & "*.xlsx")    'premier fichier si existe
    If Fichier <> "" Then
        NbF = 1
        Do While Fichier <> ""
            If NbF = 1 Then
                CLD = "$A$1"        'cellules titre colonnes pour copie
                Of7 = 1                 'offset ligne de depart
                LM = 1                  'offset ligne de fin
            Else
                CLD = "$A$2"        'cellules sans titre pour copie
                Of7 = 0
                LM = 2
            End If
            Workbooks.Open Chemin_Fichier & Fichier     'ouverture fichier
                With ActiveSheet
                    Plage = .UsedRange.Address
                    TAdr = Split(Plage, ":")
                    ColF = Split(TAdr(1), "$")
                    ColNF = Chr(Asc(ColF(1)) + 1)       'colonne pour nom de fichier
                    LF = CLng(ColF(2)) - LM                 'nb ligne du fichier source
                    Derl = WBD.ActiveSheet.Range("A" & Rows.Count).End(xlUp).Row     'derniere  cellule non vide colonne A
                    If Derl > 1 Then Derl = Derl + 1
                    .Range(CLD & ":" & TAdr(1)).Copy WBD.ActiveSheet.Range("A" & Derl)
                    WBD.ActiveSheet.Range(ColNF & Derl + Of7 & ":" & ColNF & Derl + LF) = Fichier     ' ecriture nom du fichier
                End With
            Workbooks(Fichier).Close False      'fermeture fichier source sans sauvegarde
            Fichier = Dir       'fichier suivant si existe
            NbF = NbF + 1       '
        Loop
    Else
        MsgBox "Aucun Fichier trouve!!", vbCritical, "Annulation"
    End If
    Application.ScreenUpdating = True
End Sub

adeza74 Messages postés 6 Date d'inscription Statut Membre Dernière intervention 1

C'est parfait! Merci beaucoup.

Votre réponse