XL 2010 Grouper les feuilles de plusieurs classeurs dans un seul classeur

TheProdigy

TheProdigy

XLDnaute Impliqué
Bonjour tout le monde,

Je voudrais réunir la première feuille de plusieurs classeurs qui sont nommés sous format date ##_ ##_## et qui contiennent un tableau dans leurs premières feuilles. Ledit tableau est du même format pour tous les classeurs mais les données sont différentes selon leurs dates.

Mon souhait est :
  • D’avoir un nouveau classeur qui regroupe toutes les premières feuilles de tous les classeurs ;
  • (Optionnel), et si possible le nom des feuilles soit égal aux noms (Date) des classeurs.
Merci d’avance
 

Pièces jointes

  • 01_04_20.xlsx
    159 KB · Affichages: 25
Solution
job75
Fichier (1 bis) avec la macro du post #3 modifiée :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, F As Worksheet, lig&, x$, dat1$, dat2$, dat$, h&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Do
    x = Application.Trim(InputBox("Entrez la date de début et la date de fin séparées par un espace :", "Dates", x))
    If x = "" Then Exit Sub
    dat1 = Split(x)(0)
    If InStr(x, " ") Then dat2 = Split(x)(1) Else dat2 = ""
Loop While Not IsDate(dat1) Or Not IsDate(dat2)
Application.ScreenUpdating = False
F.Rows(lig & ":" &...
Trier par date Trier par votes
job75

job75

XLDnaute Barbatruc
Bonjour adilprodigy, Dudu2,

C'est un problème classique de consolidation, moult fois traité sur XLD.

Téléchargez les fichier joints dans le même dossier et lancez cette macro :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, F As Worksheet, lig&, h&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    If fichier Like "##_##_##*" Then
        With Workbooks.Open(chemin & fichier).Sheets(1)
            h = .Cells(1).CurrentRegion.Rows.Count
            .Rows(1).Resize(h).Copy F.Cells(lig, 1)
            lig = lig + h
            .Parent.Close False
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
Les 2 lignes de titres sont copiées à chaque fois car elles ne sont pas identiques, vous en ferez ce que vous voulez.

A+
 

Pièces jointes

  • Consolidation(1).xlsm
    60 KB · Affichages: 25
  • 01_04_20.xlsx
    116.5 KB · Affichages: 18
  • 01_05_20.xlsx
    119.4 KB · Affichages: 12
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Avec la macro précédente l'ouverture et la fermeture de chaque fichier prennent chez moi 0,32 s.

S'il y a beaucoup de fichiers à consolider cela peut prendre trop de temps.

Avec cette macro du fichier (2) on utilise des formules de liaison sans ouvrir les fichiers :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, feuille$, ncol%, F As Worksheet, lig&, form$, h&, h1&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
feuille = "Feuil1" 'nom des feuilles à copier, à adapter
ncol = 29 'nombre de colonnes, à adapter
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
F.[A1].CurrentRegion.EntireRow.Offset(2).Delete 'RAZ
While fichier <> ""
    If fichier Like "##_##_##*" Then
        form = "'" & chemin & "[" & fichier & "]" & feuille & "'!"
        h = 0: h1 = 0
        On Error Resume Next
        h = ExecuteExcel4Macro("MATCH(""zzz""," & form & "C1)")
        h1 = ExecuteExcel4Macro("MATCH(9^9," & form & "C1)")
        On Error GoTo 0
        h = IIf(h > h1, h, h1)
        If h > 2 Then
            If lig > 1 Then F.Rows("1:2").Copy F.Rows(lig) 'titres
            F.Cells(lig + 1, "R") = ExecuteExcel4Macro(form & "R2C18") 'date
            F.Cells(lig + 1, "S") = ExecuteExcel4Macro(form & "R2C19") 'date
            With F.Cells(lig + 2, 1).Resize(h - 2, ncol)
                .FormulaArray = "=" & form & "R3C1:R" & h & "C" & ncol 'formule de liaison matricielle
                .Value = .Value 'supprime la formule
                .Replace 0, "", xlWhole 'supprime les zéros
            End With
            lig = lig + h
        End If
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
 

Pièces jointes

  • Consolidation(2).xlsm
    66.4 KB · Affichages: 27
Vote positif 0 Vote négatif
TheProdigy

TheProdigy

XLDnaute Impliqué
job75 à dit:
Bonjour adilprodigy, Dudu2,

C'est un problème classique de consolidation, moult fois traité sur XLD.

Téléchargez les fichier joints dans le même dossier et lancez cette macro :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, F As Worksheet, lig&, h&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    If fichier Like "##_##_##*" Then
        With Workbooks.Open(chemin & fichier).Sheets(1)
            h = .Cells(1).CurrentRegion.Rows.Count
            .Rows(1).Resize(h).Copy F.Cells(lig, 1)
            lig = lig + h
            .Parent.Close False
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
Les 2 lignes de titres sont copiées à chaque fois car elles ne sont pas identiques, vous en ferez ce que vous voulez.

A+
Cliquez pour agrandir...

Bonjour,

Merci, cela suppose que j'ouvre tous les fichiers ensuite exécuter la Macro. N'est-ce pas?
 
Vote positif 0 Vote négatif
TheProdigy

TheProdigy

XLDnaute Impliqué
job75 à dit:
Avec la macro précédente l'ouverture et la fermeture de chaque fichier prennent chez moi 0,32 s.

S'il y a beaucoup de fichiers à consolider cela peut prendre trop de temps.

Avec cette macro du fichier (2) on utilise des formules de liaison sans ouvrir les fichiers :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, feuille$, ncol%, F As Worksheet, lig&, form$, h&, h1&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
feuille = "Feuil1" 'nom des feuilles à copier, à adapter
ncol = 29 'nombre de colonnes, à adapter
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
F.[A1].CurrentRegion.EntireRow.Offset(2).Delete 'RAZ
While fichier <> ""
    If fichier Like "##_##_##*" Then
        form = "'" & chemin & "[" & fichier & "]" & feuille & "'!"
        h = 0: h1 = 0
        On Error Resume Next
        h = ExecuteExcel4Macro("MATCH(""zzz""," & form & "C1)")
        h1 = ExecuteExcel4Macro("MATCH(9^9," & form & "C1)")
        On Error GoTo 0
        h = IIf(h > h1, h, h1)
        If h > 2 Then
            If lig > 1 Then F.Rows("1:2").Copy F.Rows(lig) 'titres
            F.Cells(lig + 1, "R") = ExecuteExcel4Macro(form & "R2C18") 'date
            F.Cells(lig + 1, "S") = ExecuteExcel4Macro(form & "R2C19") 'date
            With F.Cells(lig + 2, 1).Resize(h - 2, ncol)
                .FormulaArray = "=" & form & "R3C1:R" & h & "C" & ncol 'formule de liaison matricielle
                .Value = .Value 'supprime la formule
                .Replace 0, "", xlWhole 'supprime les zéros
            End With
            lig = lig + h
        End If
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
Cliquez pour agrandir...

Merci,

Le chemin de mes fichiers est E:\CDG\Placm\VIL Comment réadapter ton code pour qu'il connaisse ce chemin?
Est-ce qu'elle prend les données jusqu'à la dernière ligne du tableau?

Merci
 
Dernière édition:
Vote positif 0 Vote négatif
TheProdigy

TheProdigy

XLDnaute Impliqué
job75 à dit:
Bonjour adilprodigy, Dudu2,

C'est un problème classique de consolidation, moult fois traité sur XLD.

Téléchargez les fichier joints dans le même dossier et lancez cette macro :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, F As Worksheet, lig&, h&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    If fichier Like "##_##_##*" Then
        With Workbooks.Open(chemin & fichier).Sheets(1)
            h = .Cells(1).CurrentRegion.Rows.Count
            .Rows(1).Resize(h).Copy F.Cells(lig, 1)
            lig = lig + h
            .Parent.Close False
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
Les 2 lignes de titres sont copiées à chaque fois car elles ne sont pas identiques, vous en ferez ce que vous voulez.

A+
Cliquez pour agrandir...

Merci beaucoup, exactement ce que je voulais. Ce que je ne savais pas c'est que le fichier devrait être placé dans le même dossier que les fichier sources.

Impeccable merci beaucoup @job75
 
Vote positif 0 Vote négatif
TheProdigy

TheProdigy

XLDnaute Impliqué
job75 à dit:
Bonjour adilprodigy, Dudu2,

C'est un problème classique de consolidation, moult fois traité sur XLD.

Téléchargez les fichier joints dans le même dossier et lancez cette macro :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, F As Worksheet, lig&, h&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    If fichier Like "##_##_##*" Then
        With Workbooks.Open(chemin & fichier).Sheets(1)
            h = .Cells(1).CurrentRegion.Rows.Count
            .Rows(1).Resize(h).Copy F.Cells(lig, 1)
            lig = lig + h
            .Parent.Close False
        End With
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
Les 2 lignes de titres sont copiées à chaque fois car elles ne sont pas identiques, vous en ferez ce que vous voulez.

A+
Cliquez pour agrandir...
Bonjour,

Comment adapter le code pour ne prendre qu'une intervalle de temps précise, lui exiger de ne consolider que les fichiers entre date 1 ##_##_## et date 2 ##_##_##

Merci
 
Vote positif 0 Vote négatif
job75

job75

XLDnaute Barbatruc
Fichier (1 bis) avec la macro du post #3 modifiée :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, F As Worksheet, lig&, x$, dat1$, dat2$, dat$, h&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Do
    x = Application.Trim(InputBox("Entrez la date de début et la date de fin séparées par un espace :", "Dates", x))
    If x = "" Then Exit Sub
    dat1 = Split(x)(0)
    If InStr(x, " ") Then dat2 = Split(x)(1) Else dat2 = ""
Loop While Not IsDate(dat1) Or Not IsDate(dat2)
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    dat = Replace(Left(fichier, Len(fichier) - 5), "_", "/")
    If IsDate(dat) Then
        If CDate(dat) >= CDate(dat1) And CDate(dat) <= CDate(dat2) Then
            With Workbooks.Open(chemin & fichier).Sheets(1)
                h = .Cells(1).CurrentRegion.Rows.Count
                .Rows(1).Resize(h).Copy F.Cells(lig, 1)
                lig = lig + h
                .Parent.Close False
            End With
        End If
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
 

Pièces jointes

  • Consolidation(1 bis).xlsm
    61.7 KB · Affichages: 15
Vote positif 0 Vote négatif
Solution
TheProdigy

TheProdigy

XLDnaute Impliqué
job75 à dit:
Fichier (1 bis) avec la macro du post #3 modifiée :
VB: 
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, F As Worksheet, lig&, x$, dat1$, dat2$, dat$, h&
chemin = ThisWorkbook.Path & "\" 'dossier à adapter
fichier = Dir(chemin & "*.xlsx") '1er fichier du dossier
Set F = Feuil1 'CodeName de la feuille de restitution, à adapter
lig = 1 '1ère ligne de restitution, à adapter
Do
    x = Application.Trim(InputBox("Entrez la date de début et la date de fin séparées par un espace :", "Dates", x))
    If x = "" Then Exit Sub
    dat1 = Split(x)(0)
    If InStr(x, " ") Then dat2 = Split(x)(1) Else dat2 = ""
Loop While Not IsDate(dat1) Or Not IsDate(dat2)
Application.ScreenUpdating = False
F.Rows(lig & ":" & F.Rows.Count).Delete 'RAZ
While fichier <> ""
    dat = Replace(Left(fichier, Len(fichier) - 5), "_", "/")
    If IsDate(dat) Then
        If CDate(dat) >= CDate(dat1) And CDate(dat) <= CDate(dat2) Then
            With Workbooks.Open(chemin & fichier).Sheets(1)
                h = .Cells(1).CurrentRegion.Rows.Count
                .Rows(1).Resize(h).Copy F.Cells(lig, 1)
                lig = lig + h
                .Parent.Close False
            End With
        End If
    End If
    fichier = Dir 'fichier suivant
Wend
F.Columns.AutoFit 'ajuste les largeurs
With F.UsedRange: End With 'actualise les barres de défilement
End Sub
Cliquez pour agrandir...

Bonjour,

Merci beaucoup @job75 ton programme fonctionne parfaitement.

J'ai par contre j'ai une seule question; ta deuxième solution (Quatrième post)qui fonctionne avec des formules de liaisons je l'ai pas comprise est ce qu'elle est plus rapide que celle du troisième post?

Cordialement
 
Vote positif 0 Vote négatif

Discussions similaires

Dudu2
  • Question
XL 2016 VBA - Mes projets VBA s'affichent dans des fenêtres de l'éditeur VBA différentes
Réponses
1
Affichages
214
TooFatBoy
TooFatBoy
M
  • Question
XL 2016 macro copier coller de plusieurs feuilles excel
Réponses
2
Affichages
419
klin89
klin89
A
  • Question
XL 2019 Inquire - Connaître toutes les dépendances d'un classeur
Réponses
3
Affichages
350
Dranreb
Dranreb
H
  • Question
Power Query Récupérer une donnée dans des classeurs pour afficher le résultat dans un autre classeur
Réponses
5
Affichages
476
hijackfr
H
S
  • Question
XL 2019 Calculer dimanche de pâques puis insertion du 29 février
2
Réponses
26
Affichages
311
dysorthographie
dysorthographie
Khrysthof
  • Résolu(e)
XL 2013 Empêcher l'affichage d'une fenêtre flottante pour certaines feuilles spécifiques dans un classeur
Réponses
5
Affichages
87
Khrysthof
Khrysthof
G
  • Question
Microsoft 365 Avoir des classeurs maitres et les procédures dans un autre classeur.
2
Réponses
18
Affichages
1 K
GClaire
G
KTM
  • Question
XL 2019 Regrouper les données de plusieurs feuilles dans une seule Feuille
Réponses
9
Affichages
423
Oneida
Oneida
L
  • Question
Microsoft 365 Macro choisir onglet à exporter dans un nouveau classeur
Réponses
5
Affichages
677
l.et.lilou
L
P
  • Question
Autres Evenements VBA - Fermeture du classeur (Croix grise sur fond jaune) / fermeture de l'application (Croix rouge sur fond blanc)
Réponses
12
Affichages
779
papat0
P

Membres actuellement en ligne

15 membres et 220 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
315 103
Messages
2 116 229
Membres
112 690
dernier inscrit
noureddinee