Creer dossier

[francoislaur]

Bonjour

je cherche a modifier le code ci-joint afin de créer le dossier dans le fichier source au lieu de le créer a la base du lecteur.
Sub CreerDossier()

Dim Fe As Worksheet
Dim Tbl(1 To 5) As String
Dim DosAnnée As String
Dim DosClient As String
Dim DosMachine As String
Dim DosIntervention As String
Dim I As Integer

Set Fe = Worksheets("PARAMETRE")

With Fe
Dossier = .Range("L4")
DosAnnée = .Range("L2")
DosClient = .Range("E4")
DosMachine = .Range("E27") & "_" & .Range("E29")
DosIntervention = .Range("E53") & "_" & .Range("E32") & "_" & .Range("F32") & "_" & .Range("G32")

End With

'stocke dans un tableau pour boucler ensuite
Tbl(1) = Dossier
Tbl(2) = Dossier & "\" & DosAnnée
Tbl(3) = Dossier & "\" & DosAnnée & "\" & DosClient
Tbl(4) = Dossier & "\" & DosAnnée & "\" & DosClient & "\" & DosMachine
Tbl(5) = Dossier & "\" & DosAnnée & "\" & DosClient & "\" & DosMachine & "\" & DosIntervention

'le lecteur par défaut est celui où est enregistré le classeur
ChDir Split(ThisWorkbook.Path, "\")(0) & "\"

For I = 1 To 5

'gère les éventuelles erreurs
On Error Resume Next

'vérifie si le dossier existe déjà
If Dir(Tbl(I), vbDirectory) = "" Then

'crée le dossier dans le lecteur
MkDir Tbl(I)

'si une erreur est générée, message et fin de procédure...
If Err.Number <> 0 Then

MsgBox "Erreur lors de la création du dossier '" & Split(Tbl(I), "\")(I - 1) & "' !"
Exit Sub

End If

End If

Next I

'enregistre une copie dans le sous-dossier avec le nom du client
ThisWorkbook.SaveCopyAs Dossier & "\" & DosAnnée & "\" & DosClient & "\" & DosMachine & "\" & DosIntervention & "\" & DosClient & "_" & DosIntervention & ".xlsm"

End Sub

je vous joint le fichier pour exemple.

merci de votre aide

François

 

[MJ13]

Re : Creer dossier

Bonjour François

Personnellement, j'utilise ce code pour créer un dossier, c'est plus pratique que Mkdir 🙂.

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long
Public sNomRep
Sub MKDossier()
 sNomRep = "C:\Test1\Test2"
 CreationDossier
End Sub
Sub CreationDossier() '(sNomRep As String)
    'ChDrive "D"
    SHCreateDirectoryEx 0&, sNomRep, 0&
End Sub

 

[francoislaur]

Re : Creer dossier

Merci de ta réponse Michel,
je vais me penché sur ta solution, en attendant j'ai modifier la ligne de commande
ChDir Split(ThisWorkbook.Path, "\")(0) & "\"
par:
ChDir Split(ThisWorkbook.Path, "NOMDOSSIER")(0) & "\"

et j'arrive a obtenir le résultat attendu.

Merci encore Michel et bonne continuation

François