Discussion :

[ouskel'n'or]

Rassemble les données de toutes les feuilles de tous les classeurs d'un répertoire avec Dir

Remarque : Ce code ne nécessite pas l'activation de "Microsoft scripting Runtime"

Exécuter la macro Appel (Fait appel à Ouvrir)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub Appel()
Dim FL1 As Worksheet, Chemin As String
    Application.ScreenUpdating = False
        'Définir le répertoire
        Chemin = "D:\xls"
        'Crée l'instance de la feuille récapitulative (FL1)
        Set FL1 = ThisWorkbook.Worksheets("Feuil1")
        Ouvrir Chemin, FL1
    Application.ScreenUpdating = True
End Sub

Liste les fichiers du répertoire (Fait appel à Copie)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
Sub Ouvrir(Chemin As String, FL1 As Worksheet)
Dim NomFich As String
    NomFich = Dir(Chemin & "\")
    If NomFich = "" Then MsgBox "Aucun fichier n'a été trouvé."
    Do While NomFich <> ""
        Workbooks.Open Chemin & "\" & NomFich
        DoEvents
        NomFich = ActiveWorkbook.Name
        Copie NomFich, FL1
        NomFich = Dir
    Loop
End Sub

Copie à la suite les données de chaque feuille des classeurs situés dans le répertoire sur FL1

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
Sub Copie(NomFich As String, FL1 As Worksheet)
     For Each LaFeuille In Workbooks(NomFich).Worksheets
        'pour copier le contenu de chaque feuille à la suite
        derlig = FL1.Cells(Rows.Count, 1).End(xlUp).Row + 1
        LaFeuille.UsedRange.Copy FL1.Range("A" & derlig)
        DoEvents
     Next
     ActiveWorkbook.Close False
     DoEvents
End Sub

Note
Pour ne copier que les valeurs sans les formules, remplacer la ligne

LaFeuille.UsedRange.Copy FL1.Range("A" & derlig)

par

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
        LaFeuille.UsedRange.Copy
        FL1.Range("A" & derlig).PasteSpecial Paste:=xlValues

Attention : si la feuille est protégée en Lecture/Ecriture, ce code générera une erreur. A gérer.

[ouskel'n'or]

Deux méthodes pour copier les feuilles de plusieurs classeurs à la suite l'une de l'autre dans une feuille unique.

Remarque : Ce code nécessite d'activer la référence "Microsoft scripting Runtime" : Dans l'éditeur VBA -> Outils -> Références -> Valider

Test1:
- crée une feuille dans le classeur contenant la procédure
- renomme cette feuille "FeuilCumul"
- Liste les classeurs du répertoire "Rep"
- Fait appel à Copie() pour réaliser la copie de chaque feuille de chaque fichier

Copie les feuilles des classeurs d'un répertoire dans une feuille de ThisWorkbook

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
Sub Test1()
Dim RepFich As Variant
Dim CL1 As Workbook, i As Byte, Rep$
Dim FL1 As Worksheet
    Set CL1 = ThisWorkbook
 
    'Ajoute une feuille au classeur destiné à recevoir les données des autres classeurs
    CL1.Sheets.Add
    CL1.ActiveSheet.Name = "FeuilCumul"
    Set FL1 = CL1.ActiveSheet 'Instance de la feuille
 
    'Répertoire des fichiers à copier
    Rep = "C:\LeRep\"
 
    'Crée le tableau des fichiers du répertoire
    Set RepFich = Application.FileSearch
 
    'Ouverture des fichiers du répertoire
    With RepFich
        .LookIn = Rep
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute(SortBy:=msoSortByFileName, _
            SortOrder:=msoSortOrderAscending) > 0 Then
            For i = 1 To .FoundFiles.Count
                DoEvents
                 Copie FL1, .FoundFiles(i)
            Next
          Else
            MsgBox "Aucun fichier dans le répertoire " & Rep
        End If
    End With
End Sub

Test2 :
- crée une feuille dans le classeur contenant la procédure
- renomme cette feuille "FeuilCumul"
- Liste les classeurs de la liste "ListFich"
- Fait appel à Copie() pour copier chaque feuille de chaque fichier

Copie les feuilles d'une liste de classeurs dans une feuille de ThisWorkbook

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
Sub Test2()
Dim ListFich As Variant
Dim CL1 As Workbook, i As Byte
Dim FL1 As Worksheet
    Set CL1 = ThisWorkbook
 
    'Ajoute une feuille au classeur destiné à recevoir les données des autres classeurs
    CL1.Sheets.Add
    CL1.ActiveSheet.Name = "FeuilCumul"
    Set FL1 = CL1.ActiveSheet 'Instance de la feuille
 
    'Crée le tableau des fichiers à copier
    ListFich = Array("C:\RepCopie\Classeur1.xls", "D:\LeRep\Classeur5.xls")
 
    'Ouverture des fichiers du répertoire
    For i = 0 To UBound(ListFich)
        Copie FL1, ListFich(i)
    Next
End Sub

Copie :
- Ouvre chaque classeur de la liste
- Liste les feuilles de chaque classeur
- Copie à la suite dans "FeuilCumul" le contenue les feuille de chacun d'eux
- Ferme chaque fichier

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Sub Copie(FL1 As Worksheet, Fichier)
Dim CL2 As Workbook
Dim FL2 As Worksheet
Dim i As Byte, Rep$, NoLigne As Long
 
     Set CL2 = Workbooks.Open(Fichier)
 
        'Parcours des feuilles de chaque classeur
        For Each FL2 In CL2.Worksheets
            'Dernière ligne où coller les données copiées dans FL2
            NoLigne = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1
 
            'Copie de la plage renseignée de chaque feuille du classeur
            FL2.Range("A1:" & Split(FL2.UsedRange.Address(0, 0), ":")(1)).Copy _
            FL1.Range("A" & NoLigne)
            DoEvents
            Set FL2 = Nothing
        Next
        CL2.Close False 'fermeture du classeur copié
        DoEvents
        Set CL2 = Nothing
End Sub

Procédure unique listant les fichiers d'un répertoire et réalisant la copie de chaque feuille dans une feuille unique de ThisWorkbook

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
Sub Test3()
Dim CL1 As Workbook, CL2 As Workbook
Dim FL1 As Worksheet, FL2 As Worksheet
Dim Fich As Variant, i As Byte, Rep$
 
    'Répertoire des fichiers à copier
    Rep = "D:\RepCopie\"
    Set CL1 = ThisWorkbook
 
    'Ajoute une feuille au classeur destiné à recevoir les données des autres classeurs
    CL1.Sheets.Add
    CL1.ActiveSheet.Name = "FeuilCumul"
 
    Set FL1 = CL1.ActiveSheet 'Instance le la feuille
 
    'Crée le tableau des fichiers du répertoire
    Set Fich = Application.FileSearch
 
    'Ouverture des fichiers du répertoire
    With Fich
        .LookIn = Rep
        .FileType = msoFileTypeExcelWorkbooks
        If .Execute(SortBy:=msoSortByFileName, _
            SortOrder:=msoSortOrderAscending) > 0 Then
            For i = 1 To .FoundFiles.Count
                Set CL2 = Workbooks.Open(.FoundFiles(i))
                DoEvents
 
                'Parcours des feuilles de chaque classeur
                For Each FL2 In CL2.Worksheets
                    'Dernière ligne où coller les données copiées dans FL2
                    NoLigne = FL1.Range("A1").SpecialCells(xlCellTypeLastCell).Row + 1
 
                    'Copie de la plage renseignée de chaque feuille du classeur
                    FL2.Range("A1:" & Split(FL2.UsedRange.Address(0, 0), ":")(1)).Copy _
                    FL1.Range("A" & NoLigne)                    DoEvents
                    Set FL2 = Nothing
                Next
                CL2.Close False 'fermeture du classeur copié
                DoEvents
                Set CL2 = Nothing
            Next i
        Else
            MsgBox "Aucun fichier dans le répertoire " & Rep
        End If
    End With
End Sub