Création arborescence dossiers et création de fichiers

**raneelbe** · 23/05/2013, 11h38

Bonjour,

Je vous écris aujourd'hui car je suis confrontée à une difficultée sur VBA que je ne parviens pas à résoudre toute seule...
J'ai fais pas mal de recherches mais rien ne semble correspondre exactement à mon besoin, ou en tous cas, impossible de trouver LA réponse dans l'immensité d'internet!

J'ai un fichier excel qui comporte l'ensemble de l'arborescence que j'aimerai créer dans un dossier "F", disons à sur le bureau de l'utilisateur.
(J'aimerai un test qui vérifie que le dossier "F" et tout son contenu n'existent pas déjà, et si tel est le cas demander de le remplacer.)
Dans ce dossier"F", vous trouvez toute une arborescence, qui comporte au moins 3 niveaux et sous-niveaux.
Dans chacun de ses dossiers et sous-dossiers créés, je souhaiterai créer des documents : Excel, Word, PPT, en fonction des informations contenues dans le fichier excel.

Le but est qu'une personne puisse se servir d'un fichier excel pour rentrer des élèments personnalisés : type de doc, reférence, etc (par document)..., sur la base d'une arborsence qui ne bouge pas, et que cela lui crée(MACRO) tous les documents en fonction des règles de nommage définies, et les dispose dans les bons dossiers de l'arborescence du dossier "F". Je ne sais pas si je suis claire!

En sachant que le fichier de référence comporte une arborescence riche et de nombreux documents personnalisés à créer. Il faut donc que la Macro puisse lire toutes les lignes du fichier. (je ne sais pas comment faire la boucle pour balayer toutes les lignes). Petite précision, j'utilise excel en anglais.

Par avance, merci à tous ceux qui prendront le temps de lire ce message et d'apporter leur aide.

Elberane.

**Daniel.C** · 23/05/2013, 11h55

Bonjour,

Je ne sais pas si je suis claire!

Pas tout à fait... Est-ce que tu pourrais donner un exemple de la disposition des données dans ton fichier ?

**Soraphiroth** · 23/05/2013, 12h00

Je pense que cette FAQ est une bonne base déjà : http://excel.developpez.com/faq/?page=FichiersDir

Pour la création des fichiers, je suppose qu'ils doivent être pré-remplis ?

**raneelbe** · 23/05/2013, 12h00

Bonjour Daniel,

Merci pour ta réponse,

Voici à peu près à quoi ressemblent les données dans le fichier.

Dossier maitre	Dossier	Sous-dossier	Sous-sous-dossier	Nom du fichier
"F"	010-Test1	010-Soustest1	010-Sousoustest1	APM_Group1_.xlsxAPMGroup1.xlsx
"F"	010-Test1	010-Soustest1	020-Sousoustest1	BPM_Group2_.xlsxBPMGroup2.xlsx
"F"	010-Test1	020-Soustest1	010-Sousoustest1	CPM_Group1_.xlsxCPMGroup1.xlsx
"F"	010-Test1	020-Soustest1	020-Sousoustest1	DPM_Group1_.docxDPMGroup1.docx
"F"	020-Test2	010-Soustest2	010-Sousoustest2	APM_Group5_.docxAPMGroup5.docx
"F"	020-Test2	010-Soustest2	020-Sousoustest	BPM_Group6_.pptxBPMGroup6.pptx
"F"	020-Test2	020-Soustest2	010-Sousoustest2	CPM_Group7_.xlsxCPMGroup7.xlsx
"F"	030-Test3	010-Soustest3	010-Sousoustest3	DPM_Group8_.xlsxDPMGroup8.xlsx
"F"	030-Test3	020-Soustest3	010-Sousoustest3	DPM_Group2_.pptxDPMGroup2.pptx
"F"	030-Test3	020-Soustest3	020-Sousoustest3	BPM_Group2_.xlsxBPMGroup2.xlsx

Pardon, j'ai posté trop vite.
C'est en fait un découpage en dossiers et sous-dossiers avec dans chaque dossier un fichier qui doit se créer. (en sachant que dans l'Excel, chaque utilisateur pourra personnaliser ses données pour adapter les noms de ses fichiers en fonction de son nom de projet, etc.)

@Soraphiroth : Bonjour, je vais regarder en détail la foire à question sur les répertoires et les dossiers, merci pour ce lien.

Dans un premier temps, j'aimerai uniquement créer l'arborescence de manière automatique en fonction du fichier excel, et que s'y ajoutent les documents (ppt, excel, etc...)
Par la suite, en effet, il serait intéressant que les documents soient pré-remplis en fonction de modèles dont je dispose.

**Soraphiroth** · 23/05/2013, 14h10

Alors un brouillon de fonctionnement :

Il faut commencer par créer les dossiers si besoin :

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
Sub test2()
 
    Dim i As Long
    Dim fin As Long
    Dim DossierParent As String
    Dim DossierEnCours As String
    Dim Fichier As String
    DossierParent = "Chemin\Vers\F"
 
    For Each Cellule In tafeuille.Range("...")
        'Vérifie si le répertoire existe.
        DossierEnCours = DossierParent + chemindossier(ActiveCell.Column, ActiveCell.Row)
        If Dir(DossierEnCours, vbDirectory + vbHidden) <> "" Then
            'Vérifie que le dossier à créer n'existe pas déjà dans le répertoire
            If Dir(DossierEnCours & "\" & NomRep, vbDirectory + vbHidden) = "" Then
                MkDir DossierEnCours & "\" & NomRep
            End If
        End If
    Next
 
    fin = tafeuille.Range("...").End(xlDown).Row
    For i = lignedébut To fin
        Fichier = tafeuille.Cells(i, colonnefichier).Value
        If InStr(Fichier, "xlsx") Then
            'création d'un xls
        ElseIf InStr(Fichier, "docx") Then
            'création d'un docx
        'ElseIf ...
            'création...
        End If
    Next
 
End Sub

Les petits bouts à complêter :

Code :

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

DossierParent = "Chemin\Vers\F"

...

Code :

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

For Each Cellule In tafeuille.Range("...")

le range correspond à la zone des dossiers, ici par exemple de la cellule "010-Test1" à "020-Sousoustest3".

Code :

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

fin = tafeuille.Range("...").End(xlDown).Row

Ici il faut mettre la 1ere case de la colonne contenant tes noms de dossiers, par exemple E1. Cela donnera le numéro de la dernière ligne remplie.

Code :

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

i = lignedébut

et

Code :

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

colonnefichier

parlent d'eux même je crois.

Normalement ça devrait créer les dossiers déjà. Essaye et dit moi si c'est bon. Je regarde pour la création des fichiers, je n'ai plus la méthode en tête (mais en gros il faut dire à excel d'ouvrir le programme correspondant au fichier).

**Daniel.C** · 23/05/2013, 17h10

Essaie :

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
Sub test()
    Dim FSO As Object, Dossier As Object
    Dim oWSS As Object, oGenvag As Object
    Dim CheminBureau As String, C As Range
    Dim wdApp As Object, pptApp As Object
    Dim wdDoc As Object, pptDoc As Object
    Set wdApp = CreateObject("Word.Application")
    Set pptApp = CreateObject("Powerpoint.Application")
    Set oWSS = CreateObject("WScript.Shell")
    CheminBureau = oWSS.SpecialFolders("Desktop")
    Set oWSS = Nothing
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set Dossier = FSO.GetFolder(CheminBureau & "\F")
    If Not Dossier Is Nothing Then
        MsgBox "Le dossier F existe"
        Exit Sub
    End If
    MkDir CheminBureau & "\F"
    ChDir CheminBureau & "\F"
    For Each C In Range([A2], Cells(Rows.Count, 1).End(xlUp))
        For i = 2 To 100
            If Cells(C.Row, i).Value = "" Then Exit For
            If Cells(C.Row, i + 1) <> "" And Cells(C.Row, i) <> Cells(C.Row - 1, i) Then
                MkDir CurDir & "\" & Cells(C.Row, i)
                ChDir CurDir & "\" & Cells(C.Row, i)
            ElseIf Right(Cells(C.Row, i), 5) = ".xlsx" Then
                Workbooks.Add
                Var = Cells(C.Row, i).Value
                ActiveWorkbook.SaveAs ThisWorkbook.ActiveSheet.Cells(C.Row, i).Value, xlOpenXMLWorkbook
                ActiveWorkbook.Close
            ElseIf Right(Cells(C.Row, i), 5) = ".docx" Then
                Set wdDoc = wdApp.Documents.Add
                wdDoc.SaveAs Cells(C.Row, i).Value, wdFormatDocumentDefault
                wdDoc.Close
            ElseIf Right(Cells(C.Row, i), 5) = ".pptx" Then
                Set pptDoc = pptApp.Presentations.Add
                pptDoc.SaveAs Cells(C.Row, i).Value
            End If
        Next i
    Next C
    On Error GoTo 0
End Sub

**raneelbe** · 23/05/2013, 17h30

Merci beaucoup Soraphiroth pour cette réponse;

je viens juste de pouvoir faire cet essai (car je suis au travail) et je me pose une question : que dois-je mettre à la place de "chemindossier"?

J'ai tenté un ActiveWorkbook avant la (), mais cela ne semble pas être cela.

Merci encore de ton aide, c'est très précieux!

@Daniel.C: Merci pour ta réponse.
Je viens de l'intégrer à mon document et de faire un test.
Voici le résultat.

La Macro génère bien un dossier "F", mais tous les dossiers sont imbriqués les uns dans les autres jusqu'à la fin.
C'est à dire que le dossier F ne contient pas un dossier "10-..." et "20-..." qui eux-mêmes contiennent d'autres dossiers, mais seulement un dossier "10-..." qui déroule tous les sous-niveaux un par un.

Egalement, je n'ai pas de fichier excel ou word qui se créent malheureusement, mais uniquement des dossiers dont le nom termine par .xls...

Merci!

**Daniel.C** · 23/05/2013, 19h31

Exact pour les dossiers, par contre les fichiers se créent correctement (uniquement pour les extensions figurant dans ton exemple) :

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
Sub test()
    Dim FSO As Object, Dossier As Object
    Dim oWSS As Object, oGenvag As Object
    Dim CheminBureau As String, C As Range
    Dim wdApp As Object, pptApp As Object
    Dim wdDoc As Object, pptDoc As Object
    Set wdApp = CreateObject("Word.Application")
    Set pptApp = CreateObject("Powerpoint.Application")
    Set oWSS = CreateObject("WScript.Shell")
    CheminBureau = oWSS.SpecialFolders("Desktop")
    Set oWSS = Nothing
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set Dossier = FSO.GetFolder(CheminBureau & "\F")
    If Not Dossier Is Nothing Then
        MsgBox "Le dossier F existe"
        Exit Sub
    End If
    MkDir CheminBureau & "\F"
    ChDir CheminBureau & "\F"
    For Each C In Range([A2], Cells(Rows.Count, 1).End(xlUp))
        ChDir CheminBureau & "\F"
        For i = 2 To 100
            If Cells(C.Row, i).Value = "" Then Exit For
            If Cells(C.Row, i + 1) <> "" And Cells(C.Row, i) <> Cells(C.Row - 1, i) Then
                MkDir CurDir & "\" & Cells(C.Row, i)
                ChDir CurDir & "\" & Cells(C.Row, i)
            ElseIf Right(Cells(C.Row, i), 5) = ".xlsx" Then
                Workbooks.Add
                Var = Cells(C.Row, i).Value
                ActiveWorkbook.SaveAs ThisWorkbook.ActiveSheet.Cells(C.Row, i).Value, xlOpenXMLWorkbook
                ActiveWorkbook.Close
            ElseIf Right(Cells(C.Row, i), 5) = ".docx" Then
                Set wdDoc = wdApp.Documents.Add
                wdDoc.SaveAs Cells(C.Row, i).Value, wdFormatDocumentDefault
                wdDoc.Close
            ElseIf Right(Cells(C.Row, i), 5) = ".pptx" Then
                Set pptDoc = pptApp.Presentations.Add
                pptDoc.SaveAs Cells(C.Row, i).Value
                pptDoc.Close
                pptApp.Quit
            Else
                ChDir CurDir & "\" & Cells(C.Row, i)
            End If
        Next i
    Next C
    On Error GoTo 0
End Sub

**Soraphiroth** · 24/05/2013, 08h55

pour Chemin\Vers\F, soit sa position est immuable et tu peux écrire directement "C:\Dossier\Dossier...\F", soit si il peut changer, faire un appel à une fenêtre de sélection de dossier :

Code :

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

1
2
3
4
5
6
7
8
9
10
11
12
13
Function CheminDossier() as string
'enregistre l'emplacement du dossier cible
 
    Dim tmp as String
    tmp = ""
 
    Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False 'interdit de sélectionner plusieurs dossiers/fichiers
    Application.FileDialog(msoFileDialogFolderPicker).Show 'affiche la fenêtre
    tmp = Application.FileDialog(msoFileDialogFolderPicker).InitialFileName 'enregistre le chemin vers le dossier
 
    CheminDossier = tmp
 
End Function

Je corrige mon code de création de dossiers, je l'ai testé il fonctionne parfaitement :

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
Function CheminDossier(ByVal colonne As Integer, ByVal ligne As Integer) As String
 
    Dim i As Byte
    Dim chemin As String
 
    For i = 5 To colonne
        chemin = chemin & "\" & TCDOFFRES.Cells(ligne, i).Value
    Next
 
    CheminDossier = chemin
 
End Function
 
Function CheminDossierParent() As String
'enregistre l'emplacement du dossier cible
 
    Dim tmp As String
    tmp = ""
 
    Application.FileDialog(msoFileDialogFolderPicker).AllowMultiSelect = False 'interdit de sélectionner plusieurs dossiers/fichiers
    Application.FileDialog(msoFileDialogFolderPicker).Show 'affiche la fenêtre
    tmp = Application.FileDialog(msoFileDialogFolderPicker).InitialFileName 'enregistre le chemin vers le dossier
 
    CheminDossierParent = tmp
 
End Function
 
Sub test2()
 
    Dim i As Long
    Dim fin As Long
    Dim DossierParent As String
    Dim DossierEnCours As String
    Dim Fichier As String
    DossierParent = CheminDossierParent()
    DossierParent = Mid(DossierParent, 1, Len(DossierParent) - 1)
 
    For Each Cellule In TCDOFFRES.Range("E6:H11")
        'Vérifie si le répertoire existe.
        DossierEnCours = DossierParent & CheminDossier(Cellule.Column, Cellule.Row)
        If Dir(DossierEnCours, vbDirectory + vbHidden) <> "" Then
            'Vérifie que le dossier à créer n'existe pas déjà dans le répertoire
        Else
            MkDir DossierEnCours
        End If
 
    Next
 
    fin = TCDOFFRES.Range("I6").End(xlDown).Row
    For i = 6 To fin
        Fichier = TCDOFFRES.Cells(i, 14).Value
        If InStr(Fichier, "xlsx") Then
            'création d'un xls
        ElseIf InStr(Fichier, "docx") Then
            'création d'un docx
        'ElseIf ...
            'création...
        End If
    Next
 
End Sub

J'essaye d'intégrer la création de fichier, mais pour l'instant ça ne marche pas même avec le code de Daniel.C (qui d'ailleurs comporte un oubli, il faut rajouter wdapp.quit à la fin sinon word reste ouvert en fond).

**Daniel.C** · 24/05/2013, 10h51

Bonjour,

Voici le code corrigé :

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
Sub test()
    Dim FSO As Object, Dossier As Object
    Dim oWSS As Object, oGenvag As Object
    Dim CheminBureau As String, C As Range
    Dim wdApp As Object, pptApp As Object
    Dim wdDoc As Object, pptDoc As Object
    Set wdApp = CreateObject("Word.Application")
    Set pptApp = CreateObject("Powerpoint.Application")
    Set oWSS = CreateObject("WScript.Shell")
    CheminBureau = oWSS.SpecialFolders("Desktop")
    Set oWSS = Nothing
    Set FSO = CreateObject("Scripting.FileSystemObject")
    On Error Resume Next
    Set Dossier = FSO.GetFolder(CheminBureau & "\F")
    If Not Dossier Is Nothing Then
        MsgBox "Le dossier F existe"
        Exit Sub
    End If
    MkDir CheminBureau & "\F"
    ChDir CheminBureau & "\F"
    For Each C In Range([A2], Cells(Rows.Count, 1).End(xlUp))
        ChDir CheminBureau & "\F"
        For i = 2 To 100
            If Cells(C.Row, i).Value = "" Then Exit For
 
            If Cells(C.Row, i + 1) <> "" And Cells(C.Row, i) <> Cells(C.Row - 1, i) Then
                MkDir CurDir & "\" & Cells(C.Row, i)
                ChDir CurDir & "\" & Cells(C.Row, i)
            ElseIf Right(Cells(C.Row, i), 5) = ".xlsx" Then
                Workbooks.Add
                ActiveWorkbook.SaveAs ThisWorkbook.ActiveSheet.Cells(C.Row, i).Value, xlOpenXMLWorkbook
                ActiveWorkbook.Close
            ElseIf Right(Cells(C.Row, i), 5) = ".docx" Then
                Var = CurDir
                Set wdDoc = wdApp.Documents.Add
                wdDoc.SaveAs CurDir & "\" & Cells(C.Row, i).Value, wdFormatDocumentDefault
                wdDoc.Close
            ElseIf Right(Cells(C.Row, i), 5) = ".pptx" Then
                Var = CurDir
                Set pptDoc = pptApp.Presentations.Add
                pptDoc.SaveAs CurDir & "\" & Cells(C.Row, i).Value
                pptDoc.Close
 
            Else
                ChDir CurDir & "\" & Cells(C.Row, i)
            End If
        Next i
    Next C
    On Error GoTo 0
    wdApp.Quit
    pptApp.Quit
End Sub

**raneelbe** · 24/05/2013, 15h14

Bonjour à tous les deux,

Merci pour vos réponses rapides. J'ai adapté vos deux solutions, qui marchent tout à fait pour la création de mon arborescence, à tous les niveaux et sous (sous, sous....) niveaux.

Il me reste maintenant la création des documents à intégrer.

@DanielC : je dois sûrement mal m'y prendre, mais lorsque je lance la macro, il me crée l'arborescence de mon fichier en entier, mais cela ne crée pas les documents en question (les folders sont vides). Certainement un problème de configuration lié à mon PC? (masterisé en anglais, XP...)

Si vous avez des idées, pour résoudre ce problème, je suis preneuse.
Je ne comprends pas, en lisant la macro, comment le système peut ignorer complètement la création des documents excel, word, etc...je n'ai pas de messages d'erreur.

@Soraphiroth : effectivement, le code pour la création de l'arborescence parfaitement

Merci beaucoup pour votre aide précieuse.

Re-bonjour,

En fait, j'ai trouvé d'où venait mon erreur pour la création des fichiers, c'était tout bêtement un problème de colonne....
Pas très maligne!

Je vois donc les dossiers ET les fichiers en question.C'est vraiment parfait, je n'y serai pas arrivée seule!

@Soraphiroth : si tu souhaite faire une seconde proposition de code pour la création des fichiers, n'hésites pas. Je serai heureuse de voir une autre méthode.

Dans tous les cas, merci beaucoup à tous les deux pour votre aide.

**Soraphiroth** · 24/05/2013, 15h22

je n'ai rien à proposer pour les fichiers, content que cela fonctionne pour toi

Oublies pas de noter les messages qui t'ont aider et de passer en résolu

**funkyf** · 25/01/2019, 17h44

Bonjour

J'ai exactement le même tableau que raneelbe, excepté que j'ai besoins de créer plus de sous-sous-dossier en colonne 4

Avec le code de Soraphiroth je n'arrive à rien, il doit y avoir une autre fonction à créer en appel, je ne sais pas faire en VBA.

Avec le code de Daniel, J'ai bien 010-Test1 et 020-Test2 en parents.
J'ai tous mes sous-dossiers respectifs niveau 010-Soustest1.
Problèmes:
-J'ai mes sous sous dossier qui s’arrêtent au 3eme dossier (030-Sousoustest1) dans le premier 010-Soustest1. Je voudrait avoir 040-Sousoustest1 et plus.
-Je n'ai aucun autre sous sous dossier (010-Sousoustest1 et plus) dans les autres sous dossiers (020-Soustest1 et plus)

Comment fermer les boucles?

Fanny

Création arborescence dossiers et création de fichiers [XL-2007]

Macros et VBA Excel

Discussions similaires

Partager

Partager