[VBA] Création de dossiers quand ils n'éxistent pas

Question

Bonjour, 

Pourriez vous me dire ce qui cloche avec ce morceau de code ?
La création des dossiers foctionne parfaitement, cependant dans le cas où tous les dossiers sont déja présent, si je relance la macro, elle m'envoie un message d'erreur au lieu de passer a la suite :/



Sub CréaArchiEnregistrement()Dim NomRepertoire As String, NomDossier As String, Annee As String, Mois As String    NomRepertoire = "\prnas02"    NomDossier = Range("B1")    Annee = Range("B2")    Mois = Range("B3")On Error GoTo Suite        If Dir(NomRepertoire & "\" & NomDossier) = "" Then MkDir (NomRepertoire & "\" & NomDossier)    Suite:    On Error GoTo Suite2    If Dir(NomRepertoire & "\" & NomDossier & "\" & Annee) = "" Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee)            Suite2:On Error GoTo Suite3    If Dir(NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois) = "" Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois)    Suite3:

Merci pour votre aide.

Mosca · Answer

Bonjour,

Tu ne dis pas quelle erreur, ni à quel endroit ça se produit.
De plus la macro est incomplète...

Difficile dans ces conditions de pouvoir t'aider.

A+

ghang · Answer

Sub CréaArchiEnregistrement()Dim NomRepertoire As String, NomDossier As String, Annee As String, Mois As String    NomRepertoire = "\prnas02"    NomDossier = Range("B1")    Annee = Range("B2")    Mois = Range("B3")On Error GoTo Suite        If Dir(NomRepertoire & "\" & NomDossier) = "" Then MkDir (NomRepertoire & "\" & NomDossier)    Suite:    On Error GoTo Suite2    If Dir(NomRepertoire & "\" & NomDossier & "\" & Annee) = "" Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee)            Suite2:On Error GoTo Suite3    If Dir(NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois) = "" Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois)    Suite3:NomFichier = NomDossier & "_" & Annee & "_" & Mois & ".xlsx"  Sheets("Synthèse").Select    Range("G4:K114").Select    Selection.Copy    Workbooks.Add    Application.DisplayAlerts = False    Range("A1").Select    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _        :=False, Transpose:=False    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _        SkipBlanks:=False, Transpose:=False    Columns("C:C").EntireColumn.AutoFit    Columns("D:D").EntireColumn.AutoFit    Columns("E:E").EntireColumn.AutoFit    With ActiveWorkbook .SaveAs Filename:=NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois & "\" & NomFichier .Close  End With     Application.DisplayAlerts = True    End Sub

Mon erreur est localisée sur la partie en gras ci dessus ( Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee) )

Mais ca ne fait aucun sens il me semble.

La suite du code n'a pas grand interêt dans la résolution de ce problème mais je te l'ai ajoutée. 
j'ai fait tourner chaques partie du code séparément afin de m'assurer de la provenance du soucis. 

Lorsque les dossiers n'existent pas, ils se créent sans erreur, par contre lorsque TOUS les dossiers existent déja, la macro m'affiche une erreur.


"Erreur d'exécution '75':

Erreur d'accès Chemin/Fichier"

Mosca · Answer

Comme c'est ecrit, tu n'a n'as pas besoin des On Error Goto.

Essayes en mettant les lignes en commentaires et regardes si l'erreur survient encore.

'On Error GoTo Suite      : inutile car l'erreur est gérée par la condition If  If Dir(NomRepertoire & "\" & NomDossier) = "" Then MkDir (NomRepertoire & "\" & NomDossier)    Suite:    ' On Error GoTo Suite2    : inutile car l'erreur est gérée par la condition IfIf Dir(NomRepertoire & "\" & NomDossier & "\" & Annee) = "" Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee)            Suite2:'On Error GoTo Suite3    : inutile car l'erreur est gérée par la condition IfIf Dir(NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois) = "" Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois)    Suite3:NomFichier = NomDossier & "_" & Annee & "_" & Mois & ".xlsx"

A+

ghang · Answer

C'est bon, j'ai trouvé une solution au problème il me semble, sous la forme :

On Error Resume NextChDir (NomRepertoire & "\" & NomDossier)If Err Then MkDir (NomRepertoire & "\" & NomDossier)On Error GoTo 0On Error Resume NextChDir (NomRepertoire & "\" & NomDossier & "\" & Annee)If Err Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee)On Error GoTo 0On Error Resume NextChDir (NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois)If Err Then MkDir (NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois)On Error GoTo 0

pijaku · Answer

Bonjour,

Une variante avec l'api windows :
Celle-ci va créer le sous dossier Mois, dans le sous dossier Annee, dans le sous dossier NomDossier, dans le sous-dossier NomRepertoire, et cela, même si NomRepertoire, NomDossier, Annee et Mois existent (ou non...)

Option Explicit

Private Declare Function SHCreateDirectoryEx Lib "Shell32.dll" Alias "SHCreateDirectoryExA" _
 (ByVal hwnd As Long, ByVal pszPath As String, ByVal lngsec As Long) As Long

Sub test()
Dim L As Long, Repertoire As String
Dim NomRepertoire As String, NomDossier As String, Annee As String, Mois As String
    NomRepertoire = "C:\Users\monNom\Desktop"
    NomDossier = "Dossier163\"
    Annee = "2016"
    Mois = "février"
    
    Repertoire = NomRepertoire & "\" & NomDossier & "\" & Annee & "\" & Mois
    L = SHCreateDirectoryEx(0&, Repertoire, 0&)
    'possibilité de tester L (0= création du rép, 183 = rép déjà créé)
End Sub

Qui plus est, si le nom du répertoire proposé contient un caractère interdit (exemple : \), celui-ci sera supprimé du nom et donc, le répertoire sera créé quand même.

[VBA] Création de dossiers quand ils n'éxistent pas

5 réponses

Votre réponse

Discussions similaires