XL 2016 Faire la synthese de plusieurs fichiers dans un seul

[KTM]

Bonjour Forum
Jai 70 fichiers que j'ai eu à renseigner sur l'année.
Sur chaque fichier il ya 2 Feuilles :
-Sur la feuille "SUIVI" les données sont les plages : B13😀20 ; H13:J20 ; B27😀34 ; H27:J34 ; B41😀48
-Sur la feuille "Liste" il s'agit de liste à copier

je voudrais les consolider en un seul par macro.
Merci

 

[Gégé-45550]

Bonjour,
3 questions :
- Comment sont nommés les 70 fichiers ? avec un nom séquentiel, comme par exemple Fichier1, Fichier2, etc, ou autrement ?
-Il me semble que seule la synthèse des "synthèses semaine" a du sens, qu'en pensez-vous ?
-Faut-il agréger simplement les 70"listes" ou peuvent-elles contenir des doublons et si oui, que faire des doublons ?
Cordialement,

 

[job75]

Bonjour KTM, Gégé-45550,

Il y a eu récemment ce fil :

https://excel-downloads.com/threads/fusionner-3-classeurs-excel-en-un-seul.20072068/#post-20549447

Il est facile d'adapter à 70 fichiers.

A+

 

[KTM]

Bonjour,
3 questions :
- Comment sont nommés les 70 fichiers ? avec un nom séquentiel, comme par exemple Fichier1, Fichier2, etc, ou autrement ?
-Il me semble que seule la synthèse des "synthèses semaine" a du sens, qu'en pensez-vous ?
-Faut-il agréger simplement les 70"listes" ou peuvent-elles contenir des doublons et si oui, que faire des doublons ?
Cordialement,

Merci
Le ficher joint est Celui qui est renseigné chaque semaine.
Je suis depuis le début de l'activité à 70 semaines.
Les fichiers sont renommés différemment.
Concernant les listes il s'agira de les réunir y compris les doublons.

Merci.

 

[Gégé-45550]

Merci
Le ficher joint est Celui qui est renseigné chaque semaine.
Je suis depuis le début de l'activité à 70 semaines.
Les fichiers sont renommés différemment.
Concernant les listes il s'agira de les réunir y compris les doublons.

Merci.

Bonjour
Comme l'a dit ,job75, voyez déjà pour adapter la réponse contenue dans le lien qu'il a donné.
Revenez ensuite s'il y a des choses que vous n'arrivez pas à faire.
Un conseil : pour des questions pratiques, il serait bon des renommer vos fichiers de façon séquentielle.
Cordialement

 

[job75]

En fait je pense que la discussion du lien ne convient pas car vous voulez consolider les tableaux des 2 feuilles.

 

[job75]

Téléchargez les 2 fichiers joints dans le même dossier (le bureau) et exécutez cette macro :

Sub Consolider()
Dim chemin$, fichier$, deb As Range, fin As Range, P As Range, Q As Range, i&, wb As Workbook, c As Range, h&
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
Application.ScreenUpdating = False
Set deb = Sheets("SUIVI").[B7]
Set fin = Sheets("SUIVI").[G7]
Set P = Sheets("SUIVI").[B13:D20,H13:J20,B27:D34,H27:J34,B41:D48]
Union(deb, fin, P) = "" 'RAZ
Set Q = Sheets("Liste bénéficiaires").Range("A11:F" & Rows.Count)
Q.Clear 'RAZ
i = 1
While fichier <> ""
    Set wb = Workbooks.Open(chemin & fichier)
    With wb.Sheets("SUIVI")
        If .Range(deb.Address) < deb Or deb = "" Then deb = .Range(deb.Address)
        If .Range(fin.Address) > fin Then fin = .Range(fin.Address)
        For Each c In P
            If IsNumeric(CStr(.Range(c.Address))) Then c = c + .Range(c.Address)
        Next
    End With
    With wb.Sheets("Liste bénéficiaires").Range(Q.Address)
        h = .Cells(.Rows.Count, 1).End(xlUp).Row - 10
        If h > 0 Then .Rows(1).Resize(h).Copy Q(i, 1): i = i + h
    End With
    wb.Close False
    fichier = Dir 'fichier suivant
Wend
End Sub

 

[Hasco]

Bonjour,

Pourquoi une macro là où power query a été inventé pour résoudre ce genre de chose.

cordialement

 

[KTM]

Bonjour,

Pourquoi une macro là où power query a été inventé pour résoudre ce genre de chose.

cordialement

Méconnaissance oblige

 

[Hasco]

Re,

Méconnaissance oblige

Alors :

Importer des données à partir d’un dossier contenant plusieurs fichiers (Power Query) - Support Microsoft

Utilisez l’expérience Get & Transform (Power Query) d’Excel pour combiner plusieurs fichiers, qui ont le même schéma, à partir d’un dossier unique dans une table unique.

support.microsoft.com

et cas particulier :

Créer une fonction d’import par lot avec Power Query

questcequecest.com

 

[job75]

Dans ce fichier (2) j'ai ajouté les Application.Calculation pour éviter le recalcul des formules.

Ainsi que le Timer.

 

[job75]

J'ai créé 70 fichiers identiques à Suivi PSL.xlsx avec toutes les cellules remplies en 1ère feuille et 10 lignes en 2ème feuille.

Chez moi sur Win 11 Excel 2019 la macro du fichier (2) s'exécute en 24 secondes.

C'est bien sûr l'ouverture et la fermeture des fichiers qui prennent du temps.

 

[KTM]

J'ai créé 70 fichiers identiques à Suivi PSL.xlsx avec toutes les cellules remplies en 1ère feuille et 10 lignes en 2ème feuille.

Chez moi sur Win 11 Excel 2019 la macro du fichier (2) s'exécute en 24 secondes.

C'est bien sûr l'ouverture et la fermeture des fichiers qui prennent du temps.

Merci Job75
C'est fantastique !

 

[job75]

Bonjour KTM, le forum,

Avec ce fichier (3) j'utilise la méthode ADO qui n'ouvre pas les fichiers :

Sub Consolider()
Dim t, chemin$, fichier$, deb As Range, fin As Range, P As Range, Q As Range, Cn As Object, n, rs As Object, v, r As Range, mem, i&
t = Timer
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set deb = Sheets("SUIVI").[B7]
Set fin = Sheets("SUIVI").[G7]
Set P = Sheets("SUIVI").[B13:D20,H13:J20,B27:D34,H27:J34,B41:D48]
Union(deb, fin, P) = "" 'RAZ
Set Q = Sheets("Liste bénéficiaires").Range("A11:F" & Rows.Count)
Q.Clear 'RAZ
Set Cn = CreateObject("ADODB.Connection")
While fichier <> ""
    n = n + 1
    Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
    '---feuille SUIVI---
    Set rs = Cn.Execute("SELECT * FROM [SUIVI$" & deb.Address(0, 0) & ":" & deb.Address(0, 0) & "]")
    v = rs.Fields.Item(0): If v < deb Or deb = "" Then deb = v
    Set rs = Cn.Execute("SELECT * FROM [SUIVI$" & fin.Address(0, 0) & ":" & fin.Address(0, 0) & "]")
    v = rs.Fields.Item(0): If v > fin Then fin = v
    For Each r In P.Rows
        Set rs = Cn.Execute("SELECT * FROM [SUIVI$" & r.Address(0, 0) & "]")
        Set v = rs.Fields
        mem = r 'matrice, plus rapide
        If IsNumeric(v.Item(0)) Then mem(1, 1) = mem(1, 1) + v.Item(0)
        If IsNumeric(v.Item(1)) Then mem(1, 2) = mem(1, 2) + v.Item(1)
        If IsNumeric(v.Item(2)) Then mem(1, 3) = mem(1, 3) + v.Item(2)
        r = mem
    Next r
    '---feuille Liste bénéficiaires---
    For Each r In Q.Rows
        Set rs = Cn.Execute("SELECT * FROM [Liste bénéficiaires$" & r.Address(0, 0) & "]")
        If IsNull(rs.Fields.Item(0)) Then Exit For
        i = i + 1
        Q.Rows(i).CopyFromRecordset rs
    Next r
    rs.Close
    Cn.Close
    fichier = Dir 'fichier suivant
Wend
'---mise en forme---
If i Then
    With Q.Resize(i)
        .Borders.Weight = xlThin 'bordures
        .Columns(2).Resize(, 2).HorizontalAlignment = xlCenter
    End With
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox n & " fichier" & IIf(n > 1, "s", "") & " consolidé" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub

Sur 70 fichiers la macro s'exécute chez moi en 8,5 secondes.

Edit : j'ai simplifié la dernière boucle en utilisant CopyFromRecordset.

A+

 

[job75]

Bonsoir KTM,

Avec ce fichier (4) ADO est encore plus rapide :

Sub Consolider()
Dim t, chemin$, fichier$, deb As Range, fin As Range, P As Range, Q As Range, a(), Cn As Object, Cd As Object, Rst As Object, n, v, r As Range, mem, tablo, i%, j%, k&
t = Timer
chemin = ThisWorkbook.Path & "\"
fichier = Dir(chemin & "*.xlsx") '1er fichier .xlsx du dossier
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Set deb = Sheets("SUIVI").[B7]
Set fin = Sheets("SUIVI").[G7]
Set P = Sheets("SUIVI").[B13:D20,H13:J20,B27:D34,H27:J34,B41:D48]
Union(deb, fin, P) = "" 'RAZ
Set Q = Sheets("Liste bénéficiaires").Range("A11:F" & Rows.Count)
Q.Clear 'RAZ
Set Cn = CreateObject("ADODB.Connection")
Set Cd = CreateObject("ADODB.Command")
Set Rst = CreateObject("ADODB.Recordset")
While fichier <> ""
    n = n + 1
    Cn.Open = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & chemin & fichier & ";Extended Properties=""Excel 12.0;HDR=No;IMEX=1;"""
    Cd.ActiveConnection = Cn
    '---feuille SUIVI---
    Cd.CommandText = "SELECT * FROM [SUIVI$" & deb.Address(0, 0) & ":" & deb.Address(0, 0) & "]"
    Rst.Open Cd, , 1, 3
    v = Rst(0)
    If v < deb Or deb = "" Then deb = v
    Rst.Close
    Cd.CommandText = "SELECT * FROM [SUIVI$" & fin.Address(0, 0) & ":" & fin.Address(0, 0) & "]"
    Rst.Open Cd, , 1, 3
    v = Rst(0)
    If v > fin Then fin = v
    Rst.Close
    For Each r In P.Areas
        mem = r
        Cd.CommandText = "SELECT * FROM [SUIVI$" & r.Address(0, 0) & "]"
        Rst.Open Cd, , 1, 3
        r.CopyFromRecordset Rst
        Rst.Close
        tablo = r 'matrice, plus rapide
        For i = 1 To 8
            For j = 1 To 3
                If IsNumeric(CStr(tablo(i, j))) Then tablo(i, j) = mem(i, j) + tablo(i, j) Else tablo(i, j) = mem(i, j)
        Next j, i
        r = tablo
    Next r
    '---feuille Liste bénéficiaires---
    For Each r In Q.Rows
        Cd.CommandText = "SELECT * FROM [Liste bénéficiaires$" & r.Address(0, 0) & "]"
        Rst.Open Cd, , 1, 3
        If IsNull(Rst(0)) Then Exit For
        k = k + 1
        Q.Rows(k).CopyFromRecordset Rst
        Rst.Close
    Next r
    Cn.Close
    fichier = Dir 'fichier suivant
Wend
'---mise en forme---
If k Then
    With Q.Resize(k)
        .Borders.Weight = xlThin 'bordures
        .Columns(2).Resize(, 2).HorizontalAlignment = xlCenter
    End With
End If
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
MsgBox n & " fichier" & IIf(n > 1, "s", "") & " consolidé" & IIf(n > 1, "s", "") & " en " & Format(Timer - t, "0.00 \sec")
End Sub

Sur 70 fichiers l'exécution se fait maintenant en 2 secondes.

A+