Fusionner trois fichiers xls

[Nazim]

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

 

[Nazim]

Re : Fusionner trois fichiers xls

Re Bonjour,

Une idée ? je suis bloqué depuis se matin sur cette problématique.
j'ai beau essayé sans succès 🙁

 

[CHALET53]

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+

 

[Nazim]

Re : Fusionner trois fichiers xls

Bonjour CHALET53,
je vais essayer de l'adapter a mes besoins.
Merci pour la réponse 🙂

A+

 

[Nazim]

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

 

[CHALET53]

Re : Fusionner trois fichiers xls

Re,

Mettre tous les fichiers dans un même répertoire

L'extension des fichiers est : .xls

 

[Nazim]

Re : Fusionner trois fichiers xls

Re,

Merci pour la réponse


Cordialement

Nazim

 

[job75]

Re : Fusionner trois fichiers xls

Bonjour Nazim, CHALET53,

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

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+

 

[job75]

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 :

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+

 

[job75]

Re : Fusionner trois fichiers xls

Re,

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

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+

 

[job75]

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 :

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.

 

[Nazim]

Re : Fusionner trois fichiers xls

Bonjour à tous,

Merci beaucoup pour vos réponses 🙂
C'est exactement ce que je cherchai .
Merci

A+

 

[Nazim]

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]

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 :

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+

 

[job75]

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 🙄

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

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+