XL 2016 Fusion de plusieurs Fichiers

[KTM]

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

 

[Hasco]

Bonjour,

Vous avez avec xl2016, accès à powerquery, faites le avec. Exemple maison mère

Bon après-midi

 

[job75]

Bonjour KTM, Roblochon,

-Jai un Fichier qui comporte 10 Feuilles que j'ai remis a des 2 collecteurs de données.

En bon français ça veut dire quoi ? Quel rôle jouent les 10 feuilles pendant la fusion ?

A+

 

[KTM]

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]

Bon d'accord, ce n'est guère compliqué mais joignez les 2 fichiers.

 

[job75]

Bonjour KTM, le forum,

Voyez les fichiers joints et cette macro :

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+

 

[KTM]

Bonjour KTM, le forum,

Voyez les fichiers joints et cette macro :

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

 

[job75]

Il s'agit donc maintenant d'une consolidation, voyez ce fichier (2) :

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

 

[KTM]

Il s'agit donc maintenant d'une consolidation, voyez ce fichier (2) :

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