Vérification et création de dossier

Version imprimable

Bonjour à tous,

Je débute sur VBA, et depuis maintenant une semaine j'essaye de créer une macro qui me permet de créer des dossiers et sous dossiers en fonction de listes sur ma feuille excel, pour cela j'ai réussi à composer ma macro.
De plus, il est question de copier un fichier source dans le dossier créer. Au final je me retrouve avec un dossier composé de plusieurs sous dossiers et un fichier. Pour le moment on va dire que tout va bien ;)
Cela fonctionne sous un principe de boucle.

Maintenant je voudrais en partant toujours de la même ligne, débuter une vérification des dossiers existants en fonction de ma feuille excel et lorsque la boucle arrive sur un dossier inexistant je voudrais avoir une message box qui me dit "le dossier "..." n'existe pas ! Voulez-vous le créer ?" Oui ou Non. Si "Oui" la macro poursuit la procédure avec la création du fichier excel et si Non la macro s'arrête.

Voici le code que j'ai pu composé :
Code:

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 Sub CreationRepertoires() Sheets("Pour la macro").Activate On Error Resume Next i = 84 While Cells(i, 1).Value <> "" If Dir(ActiveWorkbook.Path & "\" & Cells(i, 1).Value) <> "" Then MsgBox "Le dossier " & Sheets("Liste des études").Range("E1").End(xlDown).Value & " existe déjà" Else MkDir ActiveWorkbook.Path & "\" & Cells(i, 1) If Cells(i, 2).Value = "EXE" Then For j = 2 To 14 MkDir ActiveWorkbook.Path & "\" & Cells(i, 1).Value & "\" & Cells(j, 3).Value Next j Else For j = 2 To 11 MkDir ActiveWorkbook.Path & "\" & Cells(i, 1).Value & "\" & Cells(j, 4).Value Next j End If End If MsgBox "Le dossier suivant a été créé :" & Chr(10) & Sheets("Liste des études").Cells(i, 5) Exit Sub i = i + 1 Wend On Error GoTo Message_derreur If MsgBox("Voulez-vous créer le fichier répertoire ?", vbQuestion + vbYesNo) = vbYes Then Const OverwriteExisting = False Set objFSO = CreateObject("Scripting.FileSystemObject") objFSO.CopyFile "\\Commun\DOSSIER DE TRAVAIL\NR\Développement gestion client\YYNNN AVP\YYNNN AVP EXE - Répertoire.xlsx", "\\Commun\DOSSIER DE TRAVAIL\NR\Développement gestion client\" & "\" & Sheets("Pour la macro").Cells(i, 1).Value & "\" & Sheets("Pour la macro").Cells(i, 1).Value & " - Répertoire" & ".xlsx", OverwriteExisting MsgBox "Le fichier répertoire a bien été créé." Else MsgBox "Le fichier répertoire n'a pas été créé.", vbCritical End If Exit Sub Message_derreur: MsgBox "Le fichier répertoire existe déjà", vbCritical Sheets("Liste des études").Activate End Sub
Avec ce code j'arrive à tout faire ce dont j'ai besoin en création de fichiers mais dès lors que je lance la commande elle se répète autant que je veux sans prendre en compte si le dossier existe ou pas, pareil pour le fichier alors qu'il y a "OverwriteExisting", je ne comprends pas car ca a marché pendant un moment en en modifiant certaines lignes et en ajoutant des lignes ça ne marche plus.

J'espère que l'un d'entre vous va pouvoir solutionner mon problème.

Merci d'avance.

PS: Désolé si le code est un peu fouilli je suis débutant :oops:

Jok3rnoir,

27/08/2014, 18h12
Invité

Bonjour,
regarde ce lien il parle d'un autre sujet mais dedans je mis un exemple de création de répertoire.

La méthode vérifie l'existance de ou des répertoires; et le ou les crée si il n'existe pas la création en cascade est automatique!
http://www.developpez.net/forums/d14...ormulaire-vba/
28/08/2014, 08h49
Menhir

Commence par virer de ton code le "On Error Resume Next" qui ne sert qu'à le masquer les problèmes sans les résoudre et te handicape dans la recherche des solutions.
Les "On Error" sont à proscrire dans les phases de développement et, le reste du temps, ils sont à éviter ou à utiliser avec la plus extrême parcimonie.

Pour guérir un bobo, le désinfectant et l'éosine sont plus efficace que les sparadraps. :zen:

Bonjour,

Code:

1
2
3
4
5
6
7
Sub test()
Dim WinXp As New clsWindowsExporer
WinXp.Creer_Repertoires "C:\toto\toto\toto\toto" 'Crée les répertoires si ils n'existent pas
WinXp.Creer_Repertoires "C:\titi\titi\titi\titi"
msg = WinXp.Deplace_Repertoire("c:\titi", "c:\toto\")
If Trim("" & msg) <> "" Then MsgBox msg
End Sub

Code:

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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon False
Public Function Repertoires_Existe(Repertoires As String) As Boolean
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = Fso.FolderExists(Repertoires)
Set Fso = Nothing
End Function
'Taille d'un répertoire
Public Function Taille_Repertoire(Repertoire)
Dim Fso As Object
Dim Rep As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = Fso.GetFolder(Repertoire)
    Taille_Repertoire = Rep.Size
End Function
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires(NewRepertoires As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim t
Dim R As String
Dim I As Long
R = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t)
    If Trim("" & t(I)) <> "" Then
        R = R & Trim("" & t(I)) & "\"
        If Repertoires_Existe(R) = False Then Fso.CreateFolder "" & R
    End If
Next
Set Fso = Nothing
End Sub
 
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFolder Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Function Deplace_Repertoire(Source As String, Destination As String) As String
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Fso.MoveFolder Source, Destination
If Err > 0 Then Deplace_Repertoire = Err.Description
Err.Clear
On Error GoTo 0
Set Fso = Nothing
End Function
 
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire(DelRepertoire As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFolder DelRepertoire, True
Set Fso = Nothing
End Sub
'Taille d'un répertoire
Public Function Taille_Fichier(Fichier)
Dim Fso As Object
Dim Fich As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fich = Fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = Fso.FileExists(Fichier)
Set Fso = Nothing
End Function
'Retourne le nom du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_Name(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Name = Fso.GetBaseName(Fichier)
Set Fso = Nothing
End If
End Function
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = Fso.GetExtensionName(Fichier)
Set Fso = Nothing
End If
End Function
 
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFile Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.MoveFile Source, Destination
Set Fso = Nothing
End Sub
 
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier(DelFichier As String)
If Fichier_Exist(DelFichier) = True Then
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFile DelFichier, True
Set Fso = Nothing
End If
End Sub
Function AppendTxt(sFile, sText)
Dim Fso, NewFichier
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(sFile, 8)
 
NewFichier.Write sText
NewFichier.Close
 
Set NewFichier = Nothing
Set Fso = Nothing
 
End Function
 
Public Sub FichierLog(sFile, txt)
Dim FichierLog, Fso
 
FichierLog = sFile
 
 
''CreerPath FichierLog
 
Set Fso = CreateObject("Scripting.FileSystemObject")
 
If Fso.FileExists(FichierLog) = False Then EnteteFichier FichierLog
 
AppendTxt FichierLog, txt
 
Set Fso = Nothing
End Sub
 
Private Sub EnteteFichier(Fichier)
Dim txt, Fso, NewFichier
 
txt = "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & ""
txt = txt & vbCrLf
txt = txt & "   Date de création: " & Day(Now) & "/" & Month(Now) & "/" & Year(Now) & " " & Hour(Time) & ":" & Minute(Time) & vbCrLf
txt = txt & vbCrLf
txt = txt & "   " & Fichier
txt = txt & vbCrLf
txt = txt & "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & vbCrLf
txt = ""
 'WScript.Echo Fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write txt
NewFichier.Close
 
 
Set NewFichier = Nothing
Set Fso = Nothing
End Sub

28/08/2014, 11h05
Jok3rnoir

Merci pour vos réponses, je vais étudier tout ça et reviens vers vous si j'ai un problème ou si cela me convient ;)

A bientôt :)

Jok3rnoir
09/09/2014, 15h50
Jok3rnoir

Bonjour,

Je reviens vers vous suite à ma demande de code vba, en effet depuis l'autre jour j'ai pas eu l'occasion de retravailler dessus.

Cela dit, rdurupt je n'ai pas su exploiter les codes que tu m'as fourni, dès que je veux adapter un code j'ai toujours des messages d'erreurs :/
J'aimerais bien si une âme charitable pouvait m'expliquer en détail quelles fonctions utiliser par rapport à ma demande et composer une partie du code en exemple. C'est surtout la partie vérification des dossier qui me posent problème et le fait de ne pas relancer les boites de dialogues de vérification a chaque fois sinon c'est lourd comme démarche :s l'idéal serait d'être prévenu uniquement lors d'un dossier non présent et demander à le créer ?! si il existe ne rien faire.

J'espère être clair dans ma demande.

Merci d'avance.

A bientôt.

Jok3rnoir

bonjour,
dans un premier temp tu fais menu->insérer->module de classe
tu copy colle le code suivant:

Code:

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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
'Permet de vérifier si le répertoire dont le nom est précisé en paramètre (Repertoires) existe. Retourne True s'il existe, sinon False
Public Function Repertoires_Existe(Repertoires As String) As Boolean
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = Fso.FolderExists(Repertoires)
Set Fso = Nothing
End Function
'Taille d'un répertoire
Public Function Taille_Repertoire(Repertoire)
Dim Fso As Object
Dim Rep As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
    Set Rep = Fso.GetFolder(Repertoire)
    Taille_Repertoire = Rep.Size
End Function
'Crée un répertoire, dont l'emplacement et le nom sont précisé par le chemin d'accès complet précisé en argument (NewRepertoires).
Public Sub Creer_Repertoires(NewRepertoires As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Dim t
Dim R As String
Dim I As Long
R = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t)
    If Trim("" & t(I)) <> "" Then
        R = R & Trim("" & t(I)) & "\"
        If Repertoires_Existe(R) = False Then Fso.CreateFolder "" & R
    End If
Next
Set Fso = Nothing
End Sub
 
'Copie un répertoire, ainsi que tous les fichiers et sous-répertoires qu'il contient, d'une source vers une destination.
Public Sub Copie_Repertoires(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFolder Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs répertoire d'un emplacement source vers une destination.
Public Function Deplace_Repertoire(Source As String, Destination As String) As String
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Fso.MoveFolder Source, Destination
If Err > 0 Then Deplace_Repertoire = Err.Description
Err.Clear
On Error GoTo 0
Set Fso = Nothing
End Function
 
'Permet de supprimer un répertoire et tous les fichiers et sous-répertoires qu'il contient.
Public Sub Supprimer_Repertoire(DelRepertoire As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFolder DelRepertoire, True
Set Fso = Nothing
End Sub
'Taille d'un répertoire
Public Function Taille_Fichier(Fichier)
Dim Fso As Object
Dim Fich As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Set Fich = Fso.GetFile(Fichier)
    Taille_Fichier = Fich.Size
End Function
'Vérifie lexistance d'un   fichier
Public Function Fichier_Exist(Fichier As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Exist = Fso.FileExists(Fichier)
Set Fso = Nothing
End Function
'Retourne le nom du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_Name(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_Name = Fso.GetBaseName(Fichier)
Set Fso = Nothing
End If
End Function
'Retourne l'extension du fichier, à partir du chemin d'accès complet précisé en paramètre.
Public Function Fichier_extension(Fichier As String)
Dim Fso As Object
If Fichier_Exist(Fichier) = True Then
Set Fso = CreateObject("Scripting.FileSystemObject")
Fichier_extension = Fso.GetExtensionName(Fichier)
Set Fso = Nothing
End If
End Function
 
'Copie un fichier d'une source vers une destination.
Public Sub Copie_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.CopyFile Source, Destination, True
Set Fso = Nothing
End Sub
 
'Déplace un ou plusieurs fichiers d'un emplacement source vers une destination.
Public Sub Deplace_Fichier(Source As String, Destination As String)
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.MoveFile Source, Destination
Set Fso = Nothing
End Sub
 
'Supprime le ou les fichiers dont le nom est précisé en argument.
Public Sub Supprimer_Fichier(DelFichier As String)
If Fichier_Exist(DelFichier) = True Then
Dim Fso As Object
Set Fso = CreateObject("Scripting.FileSystemObject")
Fso.DeleteFile DelFichier, True
Set Fso = Nothing
End If
End Sub
Function AppendTxt(sFile, sText)
Dim Fso, NewFichier
 
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(sFile, 8)
 
NewFichier.Write sText
NewFichier.Close
 
Set NewFichier = Nothing
Set Fso = Nothing
 
End Function
 
Public Sub FichierLog(sFile, txt)
Dim FichierLog, Fso
 
FichierLog = sFile
 
 
''CreerPath FichierLog
 
Set Fso = CreateObject("Scripting.FileSystemObject")
 
If Fso.FileExists(FichierLog) = False Then EnteteFichier FichierLog
 
AppendTxt FichierLog, txt
 
Set Fso = Nothing
End Sub
 
Private Sub EnteteFichier(Fichier)
Dim txt, Fso, NewFichier
 
txt = "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & ""
txt = txt & vbCrLf
txt = txt & "   Date de création: " & Day(Now) & "/" & Month(Now) & "/" & Year(Now) & " " & Hour(Time) & ":" & Minute(Time) & vbCrLf
txt = txt & vbCrLf
txt = txt & "   " & Fichier
txt = txt & vbCrLf
txt = txt & "***********************************************************************************************************************************************************************************"
txt = txt & vbCrLf
txt = txt & vbCrLf
txt = ""
 'WScript.Echo Fichier
Set Fso = CreateObject("Scripting.FileSystemObject")
Set NewFichier = Fso.OpenTextFile(Fichier, 2, True)
NewFichier.Write txt
NewFichier.Close
 
 
Set NewFichier = Nothing
Set Fso = Nothing
End Sub

ton module de classe va prendre le nom :Classe1.
ne t'embête à changer son nom tu reprends l'exemple précédent, mais au-lieu de l'appeler Dim WinXp As New clsWindowsExporer tu l'appel Classe1

Code:

1
2
3
4
5
6
7
Sub test()
Dim WinXp As New Classe1
WinXp.Creer_Repertoires "C:\toto\toto\toto\toto" 'Crée les répertoires si ils n'existent pas
WinXp.Creer_Repertoires "C:\titi\titi\titi\titi"
msg = WinXp.Deplace_Repertoire("c:\titi", "c:\toto\")
If Trim("" & msg) <> "" Then MsgBox msg
End Sub

09/09/2014, 17h21
Jok3rnoir

Merci pour votre réponse.

J'ai effectué la démarche spécifié en effet cela fonctionne mais ne correspond pas vraiment à ce que je veux obtenir.
Je vais expliquer le contexte, ce devrait être plus clair.
Nous disposons d'un fichier excel listant l'ensemble de nos projets qui est incrémenté au fur à mesure des nouveaux projets. Chaque ligne dispose de différents champs pour renseigner le projet et donc suite au remplissage on crée manuellement un dossier avec le nom en fonction des champs et on copie colle dedans des sous dossiers à partir de sous-dossier sources. Le but de ma macro est d'automatiser ces tâches via un bouton dans le fichier excel.
Je commencerais donc la macro a partir de la dernière ligne (qui ne sera plus la dernière par la suite) pour pas reprendre en compte tous les dossiers de projets déjà créés et ensuite il faudra un système de boucle pour ne plus avoir besoin de toucher à la macro. Je ne veux pas "en fonction de la dernière ligne".

j'espère que ma démarche est plus clair ;)

Merci d'avance.

Jok3rnoir