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

adilprodigy

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
 
Ce fil a été résolu! Aller à la solution…

Fichiers joints

Dudu2

XLDnaute Accro
Bonjour,
Comment reconnait-on un classeur candidat ? Par son nom jj_mm_aa.xlsx ?
Tous les classeurs candidats sont dans le même répertoire ?
 

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+
 
Ce message a été identifié comme étant une solution!

Fichiers joints

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
 

Fichiers joints

job75

XLDnaute Barbatruc
Pour tester j'ai recopié le tableau du fichier 01_04_20.xlsx sur 10 000 lignes, durées d'exécution :

- fichier (1) => 3,9 secondes

- fichier (2) => 1,9 seconde.
 

adilprodigy

XLDnaute Impliqué
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+
Bonjour,

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

adilprodigy

XLDnaute Impliqué
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
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:

adilprodigy

XLDnaute Impliqué
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+
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
 

adilprodigy

XLDnaute Impliqué
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+
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
 

job75

XLDnaute Barbatruc
Bonjour adilprodigy,

Quelle macro vous utilisez finalement ? Celle de mon post #3 ou celle de mon post #4 ?

A+
 

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
 
Ce message a été identifié comme étant une solution!

Fichiers joints

adilprodigy

XLDnaute Impliqué
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
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
 

adilprodigy

XLDnaute Impliqué
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
Bonjour le forum,

Je voudrais revenir sur ce fil et la solution du @job75 pour vous demander comment adapter cette solution (entre deux dates) pour la Macro du post#4

Merci
 

job75

XLDnaute Barbatruc
Bonjour adilprodigy,

Après bientôt 2 mois vous ne croyez pas que c'est du réchauffé ?

Mais bon fichier (2 bis) avec la macro du post #4 modifiée :
VB:
Sub Consolider()
'se lance par les touches Ctrl+C
Dim chemin$, fichier$, feuille$, ncol%, F As Worksheet, lig&, x$, form$, dat1$, dat2$, dat$, 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
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.[A1].CurrentRegion.EntireRow.Offset(2).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
            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
    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
A+
 

Fichiers joints

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas