XL 2016 Faire la synthese de plusieurs fichiers dans un seul

KTM

KTM

XLDnaute Impliqué
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:D20 ; H13:J20 ; B27:D34 ; H27:J34 ; B41:D48
-Sur la feuille "Liste" il s'agit de liste à copier

je voudrais les consolider en un seul par macro.
Merci
 

Pièces jointes

  • Suivi PSL.xlsx
    19 KB · Affichages: 10
Trier par date Trier par votes
Gégé-45550

Gégé-45550

XLDnaute Accro
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,
 
Vote positif 0 Vote négatif
KTM

KTM

XLDnaute Impliqué
Gégé-45550 à dit:
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,
Cliquez pour agrandir...
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.
 
Vote positif 0 Vote négatif
Gégé-45550

Gégé-45550

XLDnaute Accro
KTM à dit:
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.
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Téléchargez les 2 fichiers joints dans le même dossier (le bureau) et exécutez cette macro :
VB: 
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
 

Pièces jointes

  • Consolider(1).xlsm
    36.3 KB · Affichages: 5
  • Suivi PSL.xlsx
    25 KB · Affichages: 5
Vote positif 0 Vote négatif
Hasco

Hasco

XLDnaute Barbatruc
Repose en paix
Re,
KTM à dit:
Méconnaissance oblige
Cliquez pour agrandir...
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 support.microsoft.com
Cliquez pour agrandir...
et cas particulier :

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

questcequecest.com questcequecest.com
Cliquez pour agrandir...
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
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.
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonjour KTM, le forum,

Avec ce fichier (3) j'utilise la méthode ADO qui n'ouvre pas les fichiers :
VB: 
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+
 

Pièces jointes

  • Consolider(3).xlsm
    34.7 KB · Affichages: 3
  • Suivi PSL.xlsx
    25 KB · Affichages: 1
Dernière édition:
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Bonsoir KTM,

Avec ce fichier (4) ADO est encore plus rapide :
VB: 
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+
 

Pièces jointes

  • Consolider(4).xlsm
    37.5 KB · Affichages: 9
  • Suivi PSL.xlsx
    24.9 KB · Affichages: 7
Dernière édition:
Vote positif 0 Vote négatif

Discussions similaires

G
  • Question
Power Query Regrouper les donnees de differents onglets excel de differents fichiers dans un seul fichier excel
Réponses
8
Affichages
1 K
guazzini
G
S
  • Question
XL 2019 Regrouper sur un seul onglet toutes les informations de plusieurs onglets
Réponses
3
Affichages
2 K
chris
chris
Q
  • Question
Microsoft 365 Récupérer dans un seul fichier Excel les données de plusieurs fichiers au format .xlsx
Réponses
10
Affichages
2 K
cp4
cp4
Z
  • Question
XL 2013 Compiler les données de 500 fichiers dans un seul fichier
2
Réponses
15
Affichages
1 K
job75
job75
E
  • Question
XL 2016 faciliter la recherche des données contenues dans plusieurs fichiers dans un dossier
Réponses
14
Affichages
1 K
Ernesta
E
L
  • Question
Microsoft 365 Cherche code de transposition de plusieurs fiches onglet dans un seul onglet
2
Réponses
15
Affichages
2 K
lucarn
L
N
  • Question
Fussionner 3 fichiers contenant des macros dans un seul fichier de synthese
Réponses
1
Affichages
942
Kael_88
Kael_88
H
  • Question
fusion de fichiers dans un seul fichier dans plusieurs répertoires
Réponses
2
Affichages
941
cp4
cp4
M
  • Question
XL 2013 Faire la somme de plusieurs fichiers dans un seul
Réponses
3
Affichages
832
Philippe Tulliez
P
W
  • Question
Récupération de données nommée dans plusieurs fichiers
Réponses
0
Affichages
838
whynot_93
W

Membres actuellement en ligne

4 membres et 68 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
314 485
Messages
2 110 101
Membres
110 663
dernier inscrit
ToussaintBug