XL 2010 Création dossiers et sous dossiers en VBA

jeanmi · 2 Septembre 2021

Bonjour à tous,

J’ai essayé de créer des dossiers et sous dossiers avec le code si dessous :

VB:

Sub Creat_doss_sous_doss()
'On Error GoTo gestionErreurs
date_jour = "2021-09-01" ' sera recuperée dans une cellule
MkDir "C:\Users\HP\Gestion de planning" ' niveau 1
MkDir "C:\Users\HP\Gestion de planning\Poses_du_" & date_jour 'niveau 2
MkDir "C:\Users\HP\Gestion de planning\Poses_du_" & date_jour & "\niveau 1\doc word" ' niveau 3
MkDir "C:\Users\HP\Gestion de planning\Poses_du_" & date_jour & "\niveau 1\doc Excel" ' niveau 3
End Sub

Mes problèmes :

a) Ça marche bien pour les niveaux 1 et 2
b) Ça bloc au niveau 3
c) Si je relance in y a aussi une erreur car les deux premiers niveaux existe déjà

je n'ai pas mis la première ligne, gestion erreurs, autrement il y a erreur dés le début.

Avez-vous une orientation ou solution à me donner. Merci d’avance

Cordialement

fanch55 · 2 Septembre 2021

Bonsoir, je ne vois aucune instruction pour créer le "\niveau 1\" ?

dysorthographie · 2 Septembre 2021

Bonjour,
Tu trouveras tout ce qu tu as besoin

Recherche & référence - FS0(S)

Tout ce que vous vouliez savoir sur FSOsans avoir osé le demander! '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) Dim FSO Set FSO =...

www.excel-downloads.com

VB:

Sub test()
 Creer_Repertoires Environ("UserProfile") & "\Gestion de planning\Poses_du_" & date_jour & "\niveau 1\doc Excel"
End Sub
'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)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = FSO.FolderExists(Repertoires)
Set FSO = Nothing
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)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim t, r, I
r = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t) - 1
    If Trim("" & t(I)) <> "" Then
        r = r & Trim("" & t(I))
        If Repertoires_Existe(r) = False Then FSO.CreateFolder "" & r
    End If
     r = r & "\"
Next
Set FSO = Nothing
End Sub

jeanmi · 2 Septembre 2021

dysorthographie à dit:
Bonjour,
Tu trouveras tout ce qu tu as besoin

Recherche & référence - FS0(S)

Tout ce que vous vouliez savoir sur FSOsans avoir osé le demander! '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) Dim FSO Set FSO =...

www.excel-downloads.com

VB:

Sub test() Creer_Repertoires Environ("UserProfile") & "\Gestion de planning\Poses_du_" & date_jour & "\niveau 1\doc Excel" End Sub '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) Dim FSO Set FSO = CreateObject("Scripting.FileSystemObject") Repertoires_Existe = FSO.FolderExists(Repertoires) Set FSO = Nothing 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) Dim FSO Set FSO = CreateObject("Scripting.FileSystemObject") Dim t, r, I r = "" t = Split(NewRepertoires & "\", "\") For I = 0 To UBound(t) - 1 If Trim("" & t(I)) <> "" Then r = r & Trim("" & t(I)) If Repertoires_Existe(r) = False Then FSO.CreateFolder "" & r End If r = r & "\" Next Set FSO = Nothing End Sub

Bonjour ,

Merci pour cette réponse.
j'ai regardé, mais pour un non initier cela ressemble à du chinois.

Enfin, je vais essayer d'utiliser, pas de comprendre, et voir si j'arrive à faire fonctionner.

j'aurais préféré un complément aux codes proposés en post #1 , mais ce n'est peut-être pas la bonne solution que je voulais utiliser, même si elle me semblais simple.

cordialement

dysorthographie · 2 Septembre 2021

il n'y a rien a comprendre!
j'ai fait des fonction pour faciliter le travail!

Repertoires_Existe pour voir si un répertoire existe
Creer_Repertoires pour créer une arborescence de répertoire!

VB:

Sub Creat_doss_sous_doss()
'On Error GoTo gestionErreurs
date_jour = "2021-09-01" ' sera recuperée dans une cellule
Creer_Repertoires "C:\Users\HP\Gestion de planning\Poses_du_" & date_jour & "\niveau 1\doc Excel" ' niveau 3
End Sub
'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)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = FSO.FolderExists(Repertoires)
Set FSO = Nothing
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)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim t, r, I
r = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t) - 1
    If Trim("" & t(I)) <> "" Then
        r = r & Trim("" & t(I))
        If Repertoires_Existe(r) = False Then FSO.CreateFolder "" & r
    End If
     r = r & "\"
Next
Set FSO = Nothing
End Sub

jeanmi · 3 Septembre 2021

dysorthographie à dit:

il n'y a rien a comprendre!
j'ai fait des fonction pour faciliter le travail!

Repertoires_Existe pour voir si un répertoire existe
Creer_Repertoires pour créer une arborescence de répertoire!

VB:

Sub Creat_doss_sous_doss()
'On Error GoTo gestionErreurs
date_jour = "2021-09-01" ' sera recuperée dans une cellule
Creer_Repertoires "C:\Users\HP\Gestion de planning\Poses_du_" & date_jour & "\niveau 1\doc Excel" ' niveau 3
End Sub
'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)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Repertoires_Existe = FSO.FolderExists(Repertoires)
Set FSO = Nothing
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)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim t, r, I
r = ""
t = Split(NewRepertoires & "\", "\")
For I = 0 To UBound(t) - 1
    If Trim("" & t(I)) <> "" Then
        r = r & Trim("" & t(I))
        If Repertoires_Existe(r) = False Then FSO.CreateFolder "" & r
    End If
     r = r & "\"
Next
Set FSO = Nothing
End Sub

OK, je vais faire des essais. merci
cordialement

XL 2010 Création dossiers et sous dossiers en VBA

jeanmi

XLDnaute Occasionnel

fanch55

XLDnaute Barbatruc

dysorthographie

XLDnaute Accro

Recherche & référence - FS0(S)

jeanmi

XLDnaute Occasionnel

Recherche & référence - FS0(S)

dysorthographie

XLDnaute Accro

jeanmi

XLDnaute Occasionnel

Discussions similaires