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

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
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 & ":" &...

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

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

TheProdigy

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?
 

TheProdigy

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:

TheProdigy

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
 

TheProdigy

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
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

TheProdigy

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
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 926
Membres
101 842
dernier inscrit
seb0390