XL 2016 Fusion de plusieurs Fichiers

KTM

XLDnaute Impliqué
Bonjour cher forum
-Jai un Fichier qui comporte 10 Feuilles que j'ai remis a des 2 collecteurs de données.
J'ai renommer le fichier pour le collecteur 1 Donnees1 et Donnees2 pour le second
J'aimerais pouvoir Fusionner a l'aide de macro les deux Fichiers en un seul. Comment rédiger mon code Dans le Fichier Synthèse ?
Merci
 

KTM

XLDnaute Impliqué
Merci Job75 je me réexplique.
Sur mon fichier Synthèse la feuille 1 fait la synthèse de toutes les feuilles 1 des autres fichiers ; la feuille 2 fait la synthèse de toutes les feuilles 2 et ainsi de suite.
J’espère m' être mieux expliqué. Encore Merci.
 

job75

XLDnaute Barbatruc
Bonjour KTM, le forum,

Voyez les fichiers joints et cette macro :
VB:
Sub Fusionner()
Dim chemin, liste, nf%, n%, fichier, wb As Workbook, P As Range, Q As Range
chemin = ThisWorkbook.Path & "\" 'à adapter
liste = Array("Donnees1.xlsx", "Donnees2.xlsx") 'liste à adapter
Application.ScreenUpdating = False
On Error Resume Next 'si un fichier n'est pas trouvé
With ThisWorkbook
    nf = .Worksheets.Count
    '---RAZ---
    For n = 1 To nf
        With .Worksheets(n).UsedRange
            If .Rows.Count > 1 Then .Offset(1).Resize(.Rows.Count - 1).Delete xlUp
        End With
    Next n
    '---ouvertures et vérifications---
    For Each fichier In liste
        Set wb = Nothing
        Set wb = Workbooks.Open(chemin & fichier)
        If wb Is Nothing Then MsgBox "'" & chemin & fichier & " ' introuvable...": GoTo 1
        If wb.Worksheets.Count <> nf Then MsgBox "Les fichiers n'ont pas le même nombre de feuilles !", 48: GoTo 1
    Next fichier
    '---copies---
    For Each fichier In liste
        For n = 1 To nf
            Set P = Workbooks(fichier).Worksheets(n).UsedRange
            Set Q = .Worksheets(n).UsedRange
            If P.Rows.Count > 1 Then P.Offset(1).Resize(P.Rows.Count - 1).Copy Q(Q.Rows.Count + 1, 1)
            .Worksheets(n).Columns.AutoFit 'ajustement largeurs
    Next n, fichier
End With
1 '---fermeture des fichiers---
For Each fichier In liste
    Workbooks(fichier).Close False
Next fichier
End Sub
Tous les fichiers doivent avoir le même nombre de feuilles (3 ici).

A+
 

Pièces jointes

  • Synthese(1).xlsm
    22.6 KB · Affichages: 13
  • Donnees1.xlsx
    12 KB · Affichages: 13
  • Donnees2.xlsx
    12.9 KB · Affichages: 8

KTM

XLDnaute Impliqué
Bonjour KTM, le forum,

Voyez les fichiers joints et cette macro :
VB:
Sub Fusionner()
Dim chemin, liste, nf%, n%, fichier, wb As Workbook, P As Range, Q As Range
chemin = ThisWorkbook.Path & "\" 'à adapter
liste = Array("Donnees1.xlsx", "Donnees2.xlsx") 'liste à adapter
Application.ScreenUpdating = False
On Error Resume Next 'si un fichier n'est pas trouvé
With ThisWorkbook
    nf = .Worksheets.Count
    '---RAZ---
    For n = 1 To nf
        With .Worksheets(n).UsedRange
            If .Rows.Count > 1 Then .Offset(1).Resize(.Rows.Count - 1).Delete xlUp
        End With
    Next n
    '---ouvertures et vérifications---
    For Each fichier In liste
        Set wb = Nothing
        Set wb = Workbooks.Open(chemin & fichier)
        If wb Is Nothing Then MsgBox "'" & chemin & fichier & " ' introuvable...": GoTo 1
        If wb.Worksheets.Count <> nf Then MsgBox "Les fichiers n'ont pas le même nombre de feuilles !", 48: GoTo 1
    Next fichier
    '---copies---
    For Each fichier In liste
        For n = 1 To nf
            Set P = Workbooks(fichier).Worksheets(n).UsedRange
            Set Q = .Worksheets(n).UsedRange
            If P.Rows.Count > 1 Then P.Offset(1).Resize(P.Rows.Count - 1).Copy Q(Q.Rows.Count + 1, 1)
            .Worksheets(n).Columns.AutoFit 'ajustement largeurs
    Next n, fichier
End With
1 '---fermeture des fichiers---
For Each fichier In liste
    Workbooks(fichier).Close False
Next fichier
End Sub
Tous les fichiers doivent avoir le même nombre de feuilles (3 ici).

A+
Magnifique Job75
Cest tres puissant comme code.
Sans trop vous demander comment adapter pour faire des sommations des données
ci joint deux fichiers exemples.
Grandement merci
 

Pièces jointes

  • Donnees1.xlsx
    11.5 KB · Affichages: 4
  • Donnees2.xlsx
    11.5 KB · Affichages: 4
  • Syntese.xlsx
    11.5 KB · Affichages: 5

job75

XLDnaute Barbatruc
Il s'agit donc maintenant d'une consolidation, voyez ce fichier (2) :
VB:
Sub Consolider()
Dim chemin, liste, nf%, n%, fichier, wb As Workbook, P As Range, ncol%, Q As Range, tabloP, tabloQ, i&, j%
chemin = ThisWorkbook.Path & "\" 'à adapter
liste = Array("Donnees1.xlsx", "Donnees2.xlsx") 'liste à adapter
Application.ScreenUpdating = False
On Error Resume Next 'si un fichier n'est pas trouvé
With ThisWorkbook
    nf = .Worksheets.Count
    '---RAZ---
    For n = 1 To nf
        .Worksheets(n).UsedRange.Clear
    Next n
    '---ouvertures et vérifications---
    For Each fichier In liste
        Set wb = Nothing
        Set wb = Workbooks.Open(chemin & fichier)
        If wb Is Nothing Then MsgBox "'" & chemin & fichier & " ' introuvable...": GoTo 1
        If wb.Worksheets.Count <> nf Then MsgBox "Les fichiers n'ont pas le même nombre de feuilles !", 48: GoTo 1
    Next fichier
    '---copies et sommes---
    For Each fichier In liste
        For n = 1 To nf
            Set P = Workbooks(fichier).Worksheets(n).UsedRange
            If P.Count = 1 Then Set P = P.Resize(2) 'au moins 2 éléments
            ncol = P.Columns.Count
            Set Q = .Worksheets(n).Range(P.Address)
            tabloP = P: tabloQ = Q 'matrices, plus rapides
            For i = 1 To UBound(tabloP)
                For j = 1 To ncol
                    If IsNumeric(CStr(tabloP(i, j))) And IsNumeric(tabloQ(i, j)) Then _
                        tabloQ(i, j) = tabloQ(i, j) + tabloP(i, j) Else tabloQ(i, j) = tabloP(i, j)
            Next j, i
            P.Copy Q 'pour copier les formats
            Q = tabloQ 'restitution
    Next n, fichier
End With
1 '---fermeture des fichiers---
For Each fichier In liste
    Workbooks(fichier).Close False
Next fichier
End Sub
 

Pièces jointes

  • Synthese(2).xlsm
    22.6 KB · Affichages: 17
  • Donnees1.xlsx
    11.4 KB · Affichages: 17
  • Donnees2.xlsx
    11.4 KB · Affichages: 14
Dernière édition:

KTM

XLDnaute Impliqué
Il s'agit donc maintenant d'une consolidation, voyez ce fichier (2) :
VB:
Sub Consolider()
Dim chemin, liste, nf%, n%, fichier, wb As Workbook, P As Range, ncol%, Q As Range, tabloP, tabloQ, i&, j%
chemin = ThisWorkbook.Path & "\" 'à adapter
liste = Array("Donnees1.xlsx", "Donnees2.xlsx") 'liste à adapter
Application.ScreenUpdating = False
On Error Resume Next 'si un fichier n'est pas trouvé
With ThisWorkbook
    nf = .Worksheets.Count
    '---RAZ---
    For n = 1 To nf
        .Worksheets(n).UsedRange.Clear
    Next n
    '---ouvertures et vérifications---
    For Each fichier In liste
        Set wb = Nothing
        Set wb = Workbooks.Open(chemin & fichier)
        If wb Is Nothing Then MsgBox "'" & chemin & fichier & " ' introuvable...": GoTo 1
        If wb.Worksheets.Count <> nf Then MsgBox "Les fichiers n'ont pas le même nombre de feuilles !", 48: GoTo 1
    Next fichier
    '---copies et sommes---
    For Each fichier In liste
        For n = 1 To nf
            Set P = Workbooks(fichier).Worksheets(n).UsedRange
            If P.Count = 1 Then Set P = P.Resize(2) 'au moins 2 éléments
            ncol = P.Columns.Count
            Set Q = .Worksheets(n).Range(P.Address)
            tabloP = P: tabloQ = Q 'matrices, plus rapides
            For i = 1 To UBound(tabloP)
                For j = 1 To ncol
                    If IsNumeric(CStr(tabloP(i, j))) And IsNumeric(tabloQ(i, j)) Then _
                        tabloQ(i, j) = tabloQ(i, j) + tabloP(i, j) Else tabloQ(i, j) = tabloP(i, j)
            Next j, i
            P.Copy Q 'pour copier les formats
            Q = tabloQ 'restitution
    Next n, fichier
End With
1 '---fermeture des fichiers---
For Each fichier In liste
    Workbooks(fichier).Close False
Next fichier
End Sub
Impeccable Job75
Toutes mes excuses pour le Retard.
C'est exactement ce que je voulais.
Les deux macros me seront d'une grande utilité.
Encore Merci
 

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG