balayer les onglets "x" des sous dossiers afin de les copiers sur un classeur unique

**laseck** · 04/04/2019, 13h00

Bonjour à tous,

Pouvez vous m'aider, je souhaiterai que ma procédure balai l'ensemble des fichiers xls d'un répertoire ou se trouverai le classeur et des sous répertoire ou se trouveraient les fichiers ...

je séche un peu là ...

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
Sub Importer()
    Application.DisplayAlerts = False
 
 
    'On efface toutes les données de tous les mois
    For i = 1 To 1
        f = Choose(i, "A TROUVER") '
        derln = Sheets(f).Range("A" & Rows.Count).End(xlUp)(2).Row
        Sheets(f).Range("A10:Z" & derln).ClearContents '
    Next i
    Application.ScreenUpdating = False
 
    'On ouvre successivement tous les fichiers
    Set wa = ActiveWorkbook
    chemin = ThisWorkbook.Path & "\"
    nomFichier = Dir(chemin & "*.xls*")
    Do While Len(nomFichier) > 0
        If nomFichier <> ThisWorkbook.Name Then
            Set classeur = Workbooks.Open(chemin & nomFichier)
 
            'On copie les onglets a trouver
            For i = 1 To 1
                f = Choose(i, "A TROUVER")
                derln = Sheets(f).Range("A" & Rows.Count).End(xlUp)(2).Row
                classeur.Sheets(f).Range("a10:z" & derln).Copy
                    With ThisWorkbook.Sheets(f)
                        lgn = .Range("A" & Rows.Count).End(xlUp)(2).Row
                        ThisWorkbook.Activate
                        .Range("b" & lgn).PasteSpecial xlPasteValues 'cela signifie que je veux les valeurs
                        .Range("b" & lgn).PasteSpecial xlPasteFormats ' cela signifie que je conserve le format
                        derln = .Range("A" & Rows.Count).End(xlUp).Row + 1
                        .Range("A10" & lgn & ":a" & derln) = classeur.Name 'classeur.Sheets(f).Range("A10")
                    End With
                    classeur.Activate
            Next i
            classeur.Close False
        End If
        nomFichier = Dir
    Loop
    MsgBox "Travail terminé."
    Application.DisplayAlerts = True
End Sub

Si une âme charitable peut m'aider ...

merci beaucoup

**EricDgn** · 06/04/2019, 11h31

Bonjour,

Je n'ai pas compris à quoi servait le "A TROUVER", mais voici toujours une piste:

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
Option Explicit
 
Sub ImporterOngletsDossiers()
    Dim wbA As Workbook, wbB As Workbook, wSh As Worksheet
    Dim sChemin As String, sNomFich As String, kR As Long
    Set wbA = ActiveWorkbook
    '--- supprime toutes les feuilles existantes
    '--- sauf la première (il faut en garder au moins une)
    Application.DisplayAlerts = False
    Sheets.Add Before:=Sheets(1)    '--- ajout feuille vide temporaire
    For Each wSh In wbA.Worksheets
        If wSh.Index > 1 Then wSh.Delete
    Next wSh
    Application.DisplayAlerts = True
    '--- ouvre successivement tous les fichiers du dossier
    '--- (sans aller dans les sous-dossiers)
    Application.ScreenUpdating = False
    sChemin = wbA.Path & "\"
    sNomFich = Dir(sChemin & "*.xls*")
    Do While Len(sNomFich) > 0
        If sNomFich <> wbA.Name Then
            Debug.Print sNomFich
            Set wbB = Workbooks.Open(sChemin & sNomFich)
            '--- copie tous les onglets du dossier Excel ouvert
            For Each wSh In wbB.Worksheets
                wSh.Copy After:=wbA.Sheets(wbA.Sheets.Count)
            Next wSh
            wbB.Close SaveChanges:=False
        End If
        sNomFich = Dir
    Loop
    wbA.Sheets(1).Delete    '--- supprime la feuille vide temporaire
    Application.ScreenUpdating = True
    MsgBox "Travail terminé."
End Sub

Je ne peux que recommander d'utiliser systématiquement Option Explicit (dans l'éditeur de code: menu / outils / options... cocher 'Déclaration des variables obligatoires'). Cela vous évitera bien des débogages fastidieux!

Bonne continuation.

**laseck** · 06/04/2019, 16h58

Bonjour EricDgn,

Merci beaucoup pour votre réponse.

A TROUVER est le nom des onglets qui se trouve dans les différents classeurs excel que je souhaite récupérer pour en faire une consolidation.

C'est environ 90 onglets répartie dans 10 sous dossiers.

lorsque je lance votre macro j'ai une erreur 1004 sur la ligne :

Code :

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

wbA.Sheets(1).Delete    '--- supprime la feuille vide temporaire

...
Je comprends pas pourquoi

**EricDgn** · 06/04/2019, 19h02

Chez moi je n'ai pas ce problème. Essayer en ajoutant cette ligne devant la ligne .Delete:

Code :

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

1
2
    wbA.Activate
    wbA.Sheets(1).Delete    '--- supprime la feuille vide temporaire

mais a priori ce n'est pas une bonne idée de placer 90 feuilles dans un seul classeur!

La feuille vide temporaire pourrait être utilisée pour y placer la liste des onglets.

A noter que toutes les données d'un classeur étant chargées dans la mémoire centrale, un trop gros fichier peut poser problème.

Bonne continuation.

**laseck** · 06/04/2019, 19h44

J'ai compris le problème.
Pour que votre Macro fonctionne, il faut que mon classeur soit dans le même dossier pour que le fichier contenant la procédure.
Hors, je souhaiterai améliorer mon code qui fonctionne. En effet, je cherche à consolider mes feuilles A TROUVER dans un seul onglet (classeur contenant la macro).
Les classeurs qui contiennent les données sont placés dans des sous dossiers (agence 1/....2 ect).

Pour simplifier:
Mon fichier testv3 contient la macro.
Mes deux autres fichiers ont chacun une feuille nommée "A TROUVER".
Si mes fichiers sources sont dans deux sous répertoires, et mon fichier testv3 dans le dossier répertoire, il faudrait que ma macro boucle sur l'ensemble des sous répertoire du répertoire...

Pensez vous que cela soit possible? j'avoue être novice dans VBA mais mes recherches n'aboutissent pas ...
Je trouve des solutions mais je ne vois pas comment les mettre en place.

**EricDgn** · 08/04/2019, 12h03

Bonjour,

Un début de solution avec ceci, qui va rechercher tous les fichiers *.xls* dans le dossier de départ et tous ses sous-dossiers.

Si tous les onglets ont le même nom dans chaque fichier, leurs copies auront ce nom complété par un n° entre parenthèses.

La première feuille du fichier contient la liste des fichiers et des onglets copiés. Elle peut être supprimée par la suite.

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
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
Option Explicit
 
Sub ImporterOngletsDossiers()
    Dim wbA As Workbook, wbB As Workbook, wSh As Worksheet
    Dim sChemin As String, sNomFich As String, kR As Long
    Set wbA = ActiveWorkbook
    '--- supprime toutes les feuilles existantes
    '--- sauf la première (il faut en garder au moins une)
    Application.DisplayAlerts = False
    Sheets.Add Before:=Sheets(1)    '--- ajout feuille vide temporaire
    For Each wSh In wbA.Worksheets
        If wSh.Index > 1 Then wSh.Delete
    Next wSh
    Application.DisplayAlerts = True
    '--- liste tous les fichiers *.xls* (dans dossier et sous-dossiers)
    GetFolder
    '--- trie la liste des fichiers
    With wbA.Worksheets(1).Sort
        .SetRange Range("A:A")
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    '--- charge les onglets des fichiers
    Application.ScreenUpdating = False
    kR = 1
    With wbA.Sheets(1)
        Do While .Cells(kR, 1) <> ""
            If .Cells(kR, 1) <> wbA.Name Then
                Debug.Print kR, .Cells(kR, 1)
                Set wbB = Workbooks.Open(.Cells(kR, 1))
                '--- copie tous les onglets du dossier Excel ouvert
                For Each wSh In wbB.Worksheets
                    wSh.Copy After:=wbA.Sheets(wbA.Sheets.Count)
                    kR = kR + 1
                    .Rows(kR).Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
                    .Cells(kR, 2) = wbA.Sheets(wbA.Sheets.Count).Name
                Next wSh
                wbB.Close SaveChanges:=False
            End If
            kR = kR + 1
        Loop
    End With
    'wbA.Sheets(1).Delete    '--- supprime la feuille vide temporaire
    Application.ScreenUpdating = True
    MsgBox "Travail terminé."
End Sub
 
'--- http://buffalobi.com/excel/excel-vba-list-files-folders-subfolders/
Sub GetFolder()
    Cells.ClearContents
    Range("A1").Select
    Dim strPath As String
    strPath = ActiveWorkbook.path
    Dim Obj As Object, Folder As Object, File As Object
    Set Obj = CreateObject("Scripting.FileSystemObject")
    Set Folder = Obj.GetFolder(strPath)
    Call ListFiles(Folder)
    Dim SubFolder As Object
    For Each SubFolder In Folder.SubFolders
        Call ListFiles(SubFolder)
        Call GetSubFolders(SubFolder)
    Next SubFolder
    Range("A1").Select
End Sub
 
Sub ListFiles(ByRef Folder As Object)
    Dim File As Object
    For Each File In Folder.Files
    If File.Name Like "*.xls*" Then
        ActiveCell = File.path ' & "\" & File.Name
        ActiveCell.Offset(1, 0).Select
    End If
    Next File
End Sub
 
Sub GetSubFolders(ByRef SubFolder As Object)
    Dim FolderItem As Object
    For Each FolderItem In SubFolder.SubFolders
        Call ListFiles(FolderItem)
        Call GetSubFolders(FolderItem)
    Next FolderItem
End Sub

Bonne continuation.

**laseck** · 08/04/2019, 18h22

Ok merci il faut que j'étudies cela.

Par contre est ce normal que la procédure ne me ramène que des liens dans la colonne A?

**EricDgn** · 09/04/2019, 14h08

Bonjour,
En colonne A: les chemin/nom fichiers, en colonne B: noms des onglets copiés des fichiers.
Cordialement.

**laseck** · 09/04/2019, 16h40

Re bonjour

,

Alors j'ai regardé l'impact de la macro.
Je n'ai rien qui se rapatrie. J'ai uniquement en colonne A les liens des fichiers mais je n'ai rien d'autres ...
Je suis donc un peu perdu

.
Je vais continuer de chercher car je pense pas être loin avec mon fichier...
Il me manque que cette boucle qui irait chercher tous mes onglets "A TROUVER" dans l'ensemble des classeurs d'un répertoire et de ses sous répertoires.

Merci

**EricDgn** · 10/04/2019, 01h06

La macro à lancer est ImporterOngletsDossiers, qui fait appel à GetFolder.
Cette dernière, GetFolder, ne fait que lister les fichiers (en colonne A).
La première, ImporterOngletsDossiers, charge les onglets de ces fichiers (liste en colonne B).
S'il y a beaucoup de fichiers et d'onglets, cela peut prendre un moment!
Cdt.

balayer les onglets "x" des sous dossiers afin de les copiers sur un classeur unique

Macros et VBA Excel

Discussions similaires

Partager

Partager