XL 2010 Création dossiers et sous dossiers en VBA

jeanmi

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
 
Trier par date Trier par votes
dysorthographie

dysorthographie

XLDnaute Accro
Bonjour,
Tu trouveras tout ce qu tu as besoin

www.excel-downloads.com

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 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
 
Dernière édition:
Vote positif 0 Vote négatif
jeanmi

jeanmi

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

www.excel-downloads.com

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 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
Cliquez pour agrandir...
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
 
Vote positif 0 Vote négatif
dysorthographie

dysorthographie

XLDnaute Accro
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:
Vote positif 0 Vote négatif
jeanmi

jeanmi

XLDnaute Occasionnel
dysorthographie à dit:
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
Cliquez pour agrandir...
OK, je vais faire des essais. merci
cordialement
 
Vote positif 0 Vote négatif

Discussions similaires

C
  • Question
Microsoft 365 Créer dossiers, sous-dossiers et enregistrer sous OneDrive en ligne
Réponses
0
Affichages
168
Casim
C
ralph45
  • Question
Microsoft 365 Résolu [VBA] Suppression de sous-dossiers et dossiers vides
Réponses
6
Affichages
938
Dranreb
Dranreb
R
  • Question
XL 2019 Ajouter quelques propriétés au code existant (liste répertoires et sous-répertoires)
Réponses
9
Affichages
904
re4
R
jeanmi
  • Question
XL 2010 Insertion image / Word à partir d’Excel à lire texte d’explication
Réponses
2
Affichages
1 K
jeanmi
jeanmi
oguruma
POWERQUERY :: Combinaisons (Table.Combine) de dossiers contenant des fichiers .CSV ou des fichiers Excel - V2
Réponses
0
Affichages
269
oguruma
oguruma
D
  • Question
XL 2010 Création et mise à jour d'un TCD tableau croisé dynamique avec macro VBA
Réponses
1
Affichages
2 K
chris
chris
B
  • Question
XL 2019 bug dans l'enregistrement (VBA)
Réponses
9
Affichages
1 K
bluesky12000
B
R
  • Résolu(e)
XL 2016 Lister fichiers avec Exifs et propriétés (suivant son choix) - code à modifier
10 11 12
Réponses
167
Affichages
13 K
re4
R
N
  • Résolu(e)
XL 2016 Lenteur à l'insertion de ligne en VBA
Réponses
5
Affichages
2 K
Nicocotte125
N
S
  • Question
XL 2013 Convertir classeur en PDF, crypter avec mot de passe et envoyer via Outlook
Réponses
2
Affichages
1 K
Saliou MBALO
S

Membres actuellement en ligne

11 membres et 83 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 196
Messages
2 086 094
Membres
103 116
dernier inscrit
kutobi87