XL 2010 Création dossiers et sous dossiers en VBA

  • Initiateur de la discussion Initiateur de la discussion jeanmi
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

jeanmi

XLDnaute Occasionnel
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
 
Bonjour,
Tu trouveras tout ce qu tu as besoin

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
 
Dernière édition:
Bonjour,
Tu trouveras tout ce qu tu as besoin

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
 
il n'y a rien a comprendre!
j'ai fait des fonction pour faciliter le travail!
  1. Repertoires_Existe pour voir si un répertoire existe
  2. 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
 
Dernière édition:
il n'y a rien a comprendre!
j'ai fait des fonction pour faciliter le travail!
  1. Repertoires_Existe pour voir si un répertoire existe
  2. 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
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Réponses
2
Affichages
2 K
Réponses
1
Affichages
908
Retour