XL 2010 Création dossiers et sous dossiers en VBA

Créer une discussion
Répondre
  • 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 !

S'inscrire
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
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
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
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
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
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- 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

oguruma
EXCEL : MakeDirP :: Le mkdir -p de linux reconduit en VBA pour la création d'une arborescence de dossier et sous-dossiers
Réponses
4
Affichages
325
oguruma
oguruma
C
  • Question Question
Microsoft 365 Créer dossiers, sous-dossiers et enregistrer sous OneDrive en ligne
Réponses
0
Affichages
458
Casim
C
3xceln4ute
  • Question Question
Microsoft 365 VBA export Excel vers Word : Bnq congé 0
Réponses
5
Affichages
773
Phil69970
Phil69970
ralph45
  • Question Question
Microsoft 365 Résolu [VBA] Suppression de sous-dossiers et dossiers vides
Réponses
6
Affichages
2 K
Dranreb
Dranreb
D
  • Question Question
Microsoft 365 Couper Coller Fichiers en VBA
Réponses
3
Affichages
855
patricktoulon
patricktoulon
Nico2978
  • Résolu(e)
XL 2019 Aide pour un module d'archivage de feuille en pdf dans répertoire
Réponses
5
Affichages
907
Nico2978
Nico2978
G
  • Résolu(e)
XL 2016 Pb de tri et sous totaux
2
Réponses
27
Affichages
1 K
Gestionnaire_rh
G
J
  • Résolu(e)
XL 2021 Envoi d'email et PJ en VBA
Réponses
3
Affichages
696
JPaul78
J
R
  • Question Question
XL 2019 Ajouter quelques propriétés au code existant (liste répertoires et sous-répertoires)
Réponses
9
Affichages
1 K
re4
R
jeanmi
  • Question Question
XL 2010 Insertion image / Word à partir d’Excel à lire texte d’explication
Réponses
2
Affichages
2 K
jeanmi
jeanmi
D
  • Question Question
XL 2010 Création et mise à jour d'un TCD tableau croisé dynamique avec macro VBA
Réponses
1
Affichages
3 K
chris
chris
B
  • Question Question
XL 2019 bug dans l'enregistrement (VBA)
Réponses
9
Affichages
2 K
bluesky12000
B
Y
  • Question Question
XL 2016 VBA Boucle for sur cellules visibles
Réponses
3
Affichages
2 K
herve62
herve62
XLSM75
  • Question Question
XL 2019 Extraire données d'un classeur vers un autre en réorganisant et renommant les colonnes
Réponses
10
Affichages
2 K
XLSM75
XLSM75
T
  • Résolu(e)
XL 2010 VBA - Erreur de compilation
Réponses
11
Affichages
2 K
toud
T
P
  • Question Question
XL 2019 Enregistrer et imprimer une feuille en pdf
Réponses
9
Affichages
2 K
PeewhY
P
N
  • Résolu(e)
XL 2016 Lenteur à l'insertion de ligne en VBA
Réponses
5
Affichages
3 K
Nicocotte125
N
C
  • Question Question
Word Macro sur Word
Réponses
2
Affichages
2 K
CaEly
C
S
  • Question Question
XL 2013 Convertir classeur en PDF, crypter avec mot de passe et envoyer via Outlook
Réponses
2
Affichages
2 K
Saliou MBALO
S
R
  • Question Question
XL 2019 Probleme de code VBA
Réponses
1
Affichages
925
ChTi160
ChTi160
Retour