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

[TheProdigy]

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

 

[TheProdigy]

Oui, je l'ai dit au post #5, on évite l'ouverture des fichiers.

Merci

 

[TheProdigy]

Fichier (1 bis) avec la macro du post #3 modifiée :

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]

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 :

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+