Fusionner trois fichiers xls

Nazim

XLDnaute Junior
Bonjour,

J'ai trois classeurs XLS ayant tous les même en tête (pas forcement les même lignes) mais aussi le même nom de la feuille ("page 1") je souhaite avoir un seul classeur (feuille nommé aussi "Page 1") contenant la concatenation des trois fichiers.

En pièce jointe un petit exemple de ce que je veux faire.

Merci pour votre aide

Nazim
 

Pièces jointes

  • TDC.xls
    11.3 KB · Affichages: 44
  • TDC.xls
    11.3 KB · Affichages: 44
  • TDC - 2.xls
    11 KB · Affichages: 43
  • TDC - 2.xls
    11 KB · Affichages: 44
  • TDC3.xls
    10.1 KB · Affichages: 40
  • TDC3.xls
    10.1 KB · Affichages: 36

CHALET53

XLDnaute Barbatruc
Re : Fusionner trois fichiers xls

Bonjour,

Tu peux peut-être t'inspirer de cet exemple

Le fichier Global.xls récapitule les deux fichiers
Teste en lançant l'application via le bouton

a+
 

Pièces jointes

  • ESSAI.zip
    36.5 KB · Affichages: 43
  • ESSAI.zip
    36.5 KB · Affichages: 70

Nazim

XLDnaute Junior
Re : Fusionner trois fichiers xls

RE les amis (es)

je n'arrive pas a adapter cette macro à mon besoin initial, cette macro ne copie initialement que la colonne A de chaque fichier or moi je veux qu'elle me copie toutes les colonnes:

des idées ?

Sub essai()
Dim fs, f, f1, fc, s
Dim lig_num As Long
Application.ScreenUpdating = False
specdossier = ActiveWorkbook.Path
fic = ActiveWorkbook.Name
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(specdossier)
Set fc = f.Files
For Each f1 In fc
s = f1.Name
b = Right(s, 3)
If b <> "xls" Then GoTo suite
If s = ActiveWorkbook.Name Then GoTo suite
Workbooks.Open Filename:=specdossier & "\" & s
Sheets("Page 1").Activate
For lig_num = 1 To Worksheets("Page 1").Rows.Count
derligne = Sheets("Page 1").Range("A65536").End(xlUp).Row
Range("A1:A" & derligne).Select
Selection.Copy
ActiveWorkbook.Close
Windows(fic).Activate
Sheets("Page 1").Activate
derli = Sheets("Page 1").Range("A65536").End(xlUp).Row + 1
Range("A" & derli).Select
ActiveSheet.Paste

' s = s & vbCrLf
suite:

Next
Next

End Sub
 

job75

XLDnaute Barbatruc
Re : Fusionner trois fichiers xls

Bonjour Nazim, CHALET53,

Une solution avec ExecuteExcel4Macro, pas besoin d'ouvrir les fichiers :

Code:
Sub Synthese()
Dim chemin$, fichiers, lig&, fich, derlig&, t, i&, j%
chemin = ThisWorkbook.Path & "\"
fichiers = Array("TDC.xls", "TDC - 2.xls", "TDC3.xls") 'liste des fichiers, à adapter
lig = 5 '1ère ligne
For Each fich In fichiers
  derlig = ExecuteExcel4Macro("MATCH(""zzz"",'" & chemin & "[" & fich & "]Page 1'!C1)")
  If derlig > 4 Then
    derlig = derlig - 4
    ReDim t(1 To derlig, 1 To 7) 'une colonne de plus pour les noms des fichiers
    For i = 1 To derlig
      If i = 1 Then t(1, 7) = fich 'nom du fichier
      For j = 1 To 6
        t(i, j) = ExecuteExcel4Macro("'" & chemin & "[" & fich & "]Page 1'!R" & i + 4 & "C" & j)
        If t(i, j) = 0 Then t(i, j) = ""
    Next j, i
    Cells(lig, 1).Resize(derlig, 7) = t
    lig = lig + derlig
  End If
Next fich
With Feuil1 'CodeName de la feuille
  .Range("A" & lig & ":G" & Rows.Count).ClearContents
  With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Fichiers joints, téléchargez-les dans le même répertoire (le bureau).

A+
 

Pièces jointes

  • TDC3.xls
    10.6 KB · Affichages: 39
  • TDC - 2.xls
    11.4 KB · Affichages: 31
  • TDC.xls
    11.6 KB · Affichages: 38
  • Synthèse(1).xls
    40.5 KB · Affichages: 31
  • TDC3.xls
    10.6 KB · Affichages: 35
  • TDC - 2.xls
    11.4 KB · Affichages: 31
  • TDC.xls
    11.6 KB · Affichages: 39
  • Synthèse(1).xls
    40.5 KB · Affichages: 44

job75

XLDnaute Barbatruc
Re : Fusionner trois fichiers xls

Re,

La macro précédente s'exécute chez moi (Win 8 - Excel 2013) en 6 secondes, c'est trop long.

Avec des formules de liaison en matriciel celle-ci s'exécute en 0,4 seconde :

Code:
Sub Synthese()
Dim chemin$, fichiers, lig&, fich, derlig&, f$
chemin = "'" & ThisWorkbook.Path & "\["
fichiers = Array("TDC.xls", "TDC - 2.xls", "TDC3.xls") 'liste des fichiers, à adapter
lig = 5 '1ère ligne
Application.ScreenUpdating = False
With Feuil1 'CodeName de la feuille
  .Range("A5:G" & .Rows.Count).ClearContents 'RAZ
  For Each fich In fichiers
    derlig = ExecuteExcel4Macro("MATCH(""zzz""," & chemin & fich & "]Page 1'!C1)")
    If derlig > 4 Then
      With .Cells(lig, 1).Resize(derlig - 4, 6)
        .Cells(1, 7) = fich 'nom du fichier en colonne G
        f = chemin & fich & "]Page 1'!R5C1:R" & derlig & "C6"
        .FormulaArray = "=IF(" & f & "=0,""""," & f & ")" 'formule matricielle
        .Value = .Value 'supprime les formules
      End With
      lig = lig + derlig - 4
    End If
  Next fich
  With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
C'est de loin la meilleure solution.

Fichier (2).

A+
 

Pièces jointes

  • TDC3.xls
    10.6 KB · Affichages: 33
  • TDC - 2.xls
    11.4 KB · Affichages: 34
  • TDC.xls
    11.6 KB · Affichages: 42
  • Synthèse(2).xls
    40 KB · Affichages: 31
  • TDC3.xls
    10.6 KB · Affichages: 43
  • TDC - 2.xls
    11.4 KB · Affichages: 31
  • TDC.xls
    11.6 KB · Affichages: 35
  • Synthèse(2).xls
    40 KB · Affichages: 36
Dernière édition:

job75

XLDnaute Barbatruc
Re : Fusionner trois fichiers xls

Re,

Pour peaufiner, si un fichier de la liste ou une feuille 'Page 1' n'existent pas :

Code:
Sub Synthese()
Dim chemin$, fichiers, lig&, fich, derlig As Variant, f$
chemin = "'" & ThisWorkbook.Path & "\["
fichiers = Array("TDC.xls", "TDC - 2.xls", "TDC3.xls") 'liste des fichiers, à adapter
lig = 5 '1ère ligne
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier ou une feuille n'existent pas
With Feuil1 'CodeName de la feuille
  .Range("A5:G" & .Rows.Count).ClearContents 'RAZ
  For Each fich In fichiers
    derlig = ExecuteExcel4Macro("MATCH(""zzz""," & chemin & fich & "]Page 1'!C1)")
    If IsError(derlig) Then
      MsgBox "Impossible de traiter le fichier '" & fich & "' !", 48
    Else
      If derlig > 4 Then
        With .Cells(lig, 1).Resize(derlig - 4, 6)
          .Cells(1, 7) = fich 'nom du fichier en colonne G
          f = chemin & fich & "]Page 1'!R5C1:R" & derlig & "C6"
          .FormulaArray = "=IF(" & f & "=0,""""," & f & ")" 'formule matricielle
          .Value = .Value 'supprime les formules
        End With
        lig = lig + derlig - 4
      End If
    End If
  Next fich
  With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Fichier (3).

Bonne fin de soirée.

A+
 

Pièces jointes

  • Synthèse(3).xls
    35 KB · Affichages: 28
  • Synthèse(3).xls
    35 KB · Affichages: 32

job75

XLDnaute Barbatruc
Re : Fusionner trois fichiers xls

Bonjour Nazim, CHALET53, le forum,

Voici une solution plus générale avec ce fichier (4).

On peut modifier facilement la position des tableaux, le nombre de colonnes, le nom de la feuille.

Et tous les fichiers du dossier sont étudiés, leur nombre peut être quelconque :

Code:
Sub Synthese()
Dim chemin$, deb As Range, ncol%, lig&, col%, feuil$, fich$, derlig As Variant, f$
chemin = ThisWorkbook.Path & "\"
With Feuil1 'CodeName de la feuille
  Set deb = .[A4] '1ère  cellule du tableau, à adapter
  ncol = 6 'nombre de colonnes, à adapter
  lig = deb.Row: col = deb.Column
  feuil = .Name 'Page 1 peut être modifié
  fich = Dir(chemin & "*.xls") '1er fichier .xls du dossier
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False 'si la feuille n'existe pas
  deb(2).Resize(.Rows.Count - lig, ncol + 1).ClearContents 'RAZ
  While fich <> ""
    If fich <> ThisWorkbook.Name Then
      derlig = ExecuteExcel4Macro("MATCH(""zzz"",'" & chemin & _
        "[" & fich & "]" & feuil & "'!C" & col & ")")
      If IsNumeric(derlig) Then
        If derlig > lig Then
          With deb(2).Resize(derlig - lig, ncol)
            .Cells(1, ncol + 1) = fich 'nom du fichier
            f = "'" & chemin & "[" & fich & "]" & feuil & "'!R" & _
              lig + 1 & "C" & col & ":R" & derlig & "C" & col + ncol - 1
            .FormulaArray = "=IF(" & f & "=0,""""," & f & ")" 'formule matricielle
            .Value = .Value 'supprime les formules
          End With
          Set deb = deb(derlig - lig + 1)
        End If
      End If
    End If
    fich = Dir 'fichier suivant
  Wend
  With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Edit : je joins aussi le fichier .xlsm, on n'a plus besoin de If fich <> ThisWorkbook.Name Then

Bonne journée.
 

Pièces jointes

  • Synthèse(4).xls
    41 KB · Affichages: 41
  • Synthèse(4).xlsm
    19.9 KB · Affichages: 38
Dernière édition:

Nazim

XLDnaute Junior
Re : Fusionner trois fichiers xls

Bonjour tous le monde,

J'ai essayé d'éxécuter la dernière Macro (la macro générale) sur d'autres fichier xls mais j'ai une erreur au niveau de l'instruction
derlig = ExecuteExcel4Macro("MATCH(""zzz"",'" & chemin & _
"[" & fich & "]" & feuil & "'!C" & col & ")")
 

job75

XLDnaute Barbatruc
Re : Fusionner trois fichiers xls

Re,

Pour que je puisse étudier le problème il faudrait que vous déposiez le fichier Synthèse et le fichier .xls utilisés.

Cela dit la macro beugue si dans le nom d'un fichier .xls il y a des guillemets anglais (quotes ').

Dans ce cas il faut les doubler dans les formules :

Code:
Sub Synthese()
Dim chemin$, deb As Range, ncol%, lig&, col%, feuil$, fich$, derlig As Variant, f$
chemin = ThisWorkbook.Path & "\"
With Feuil1 'CodeName de la feuille
  Set deb = .[A4] '1ère  cellule du tableau, à adapter
  ncol = 6 'nombre de colonnes, à adapter
  lig = deb.Row: col = deb.Column
  feuil = .Name 'Page 1 peut être modifié
  fich = Dir(chemin & "*.xls") '1er fichier .xls du dossier
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False 'si la feuille n'existe pas
  deb(2).Resize(.Rows.Count - lig, ncol + 1).ClearContents 'RAZ
  While fich <> ""
    If fich <> ThisWorkbook.Name Then
      fich = Replace(fich, "'", "''") 'guillemets anglais doublés
      derlig = ExecuteExcel4Macro("MATCH(""zzz"",'" & chemin & _
        "[" & fich & "]" & feuil & "'!C" & col & ")")
      If IsNumeric(derlig) Then
        If derlig > lig Then
          With deb(2).Resize(derlig - lig, ncol)
            .Cells(1, ncol + 1) = Replace(fich, "''", "'") 'nom du fichier
            f = "'" & chemin & "[" & fich & "]" & feuil & "'!R" & _
              lig + 1 & "C" & col & ":R" & derlig & "C" & col + ncol - 1
            .FormulaArray = "=IF(" & f & "=0,""""," & f & ")" 'formule matricielle
            .Value = .Value 'supprime les formules
          End With
          Set deb = deb(derlig - lig + 1)
        End If
      End If
    End If
    fich = Dir 'fichier suivant
  Wend
  With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Fichiers (5).

A+
 

Pièces jointes

  • Synthèse(5).xls
    41 KB · Affichages: 70
  • Synthèse(5).xlsm
    20.1 KB · Affichages: 35

job75

XLDnaute Barbatruc
Re : Fusionner trois fichiers xls

Re,

Je découvre que Dir(chemin & "*.xls") ne filtre pas seulement les fichiers .xls mais aussi .xlsm et .xlsx.

Je ne m'en étais jamais rendu compte auparavant :rolleyes:

En conséquence j'ai modifié le calcul de derlig :

Code:
Sub Synthese()
Dim chemin$, deb As Range, ncol%, lig&, col%, feuil$, fich$, derlig As Variant, f$
chemin = ThisWorkbook.Path & "\"
With Feuil1 'CodeName de la feuille
  Set deb = .[A4] '1ère  cellule du tableau, à adapter
  ncol = 6 'nombre de colonnes, à adapter
  lig = deb.Row: col = deb.Column
  feuil = .Name 'Page 1 peut être modifié
  fich = Dir(chemin & "*.xls") '1er fichier .xls du dossier
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False 'si la feuille n'existe pas
  deb(2).Resize(.Rows.Count - lig, ncol + 1).ClearContents 'RAZ
  While fich <> ""
    If fich <> ThisWorkbook.Name Then
      fich = Replace(fich, "'", "''") 'guillemets anglais doublés
      derlig = ExecuteExcel4Macro("MATCH(""zzz"",'" & chemin & _
        "[" & fich & "]" & feuil & "'!R1C1:R65536C" & col & ")")
      If IsNumeric(derlig) Then
        If derlig > lig Then
          With deb(2).Resize(derlig - lig, ncol)
            .Cells(1, ncol + 1) = Replace(fich, "''", "'") 'nom du fichier
            f = "'" & chemin & "[" & fich & "]" & feuil & "'!R" & _
              lig + 1 & "C" & col & ":R" & derlig & "C" & col + ncol - 1
            .FormulaArray = "=IF(" & f & "=0,""""," & f & ")" 'formule matricielle
            .Value = .Value 'supprime les formules
          End With
          Set deb = deb(derlig - lig + 1)
        End If
      End If
    End If
    fich = Dir 'fichier suivant
  Wend
  With .UsedRange: End With 'actualise la barre de défilement verticale
End With
End Sub
Fichiers (6) avec pour tous les deux la même macro précédente.

Nota : vos fichiers (.xls) TDC, TDC - 2, TDC3 ont été mal créés, ils ont 1048576 lignes et 16384 colonnes !!

A+
 

Pièces jointes

  • Synthèse(6).xls
    35.5 KB · Affichages: 36
  • Synthèse(6).xlsm
    20.3 KB · Affichages: 33

Discussions similaires

Statistiques des forums

Discussions
311 724
Messages
2 081 938
Membres
101 844
dernier inscrit
pktla