Creation dossier et sous dossier

Bonjour,

J'ai créer un classeur de devis/facturation, qui exporte une feuille en PDF, en la classant dans un dossier correspondant a une date.

J'ai voulu dernièrement allez plus loin, avec la creation d'un dossier "Année", et un sous dossier "Mois-Année" et c'est la ou je bloque.

J'ai un erreur sur le MkDir LeRepY, quand ce n'est pas sur l'export en PDF

Sub DEVIS_SP_Pdf()

    Dim LeRepY As String
    Dim LeRepS As String
    Dim DEVIS
    Dim LaDate As String
    Dim LeNom As String

    If Sheets("DEVIS HT").Range("H4") = "" Then
        MsgBox ("Il n'y a pas de numéro de devis !")
    End If

    If MsgBox("Voulez vous enregistrer le Devis sans prix en PDF ?", vbYesNo) = vbYes Then
        LaDate = Format(Date, "ddmmyyyy")                                                                           'Date du jour
        DEVIS = Sheets("DEVIS SP").Range("H4").Value                                                                'Numero du devis
        LeRepY = "C:\Users\" & Environ("Username") & "\Documents\Logiciel Devis\Devis SP\" & UCase(Format(Sheets("DEVIS SP").Range("H5").Value, "yyyy")) & "\"        'Repertoire des devis année
        LeRepS = LeRepY & UCase(Format(Sheets("DEVIS SP").Range("H5").Value, "ww-yyyy")) & "\"                     'Repertoire des devis sp
        LeNom = Sheets("DEVIS HT").Range("G11").Value                                                               'Nom du client

                If Dir(LeRepY, vbDirectory) = "" Then
                    MkDir LeRepY
                ElseIf Dir(LeRepS, vbDirectory) = "" Then
                    MkDir LeRepS
                    MsgBox "Le dossier " & LeRepS & " a été crée"
                End If

            Sheets("DEVIS SP").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
            LeRepS & "\" & "SP-" & DEVIS & "-" & LeNom & "-" & LaDate & ".pdf", Quality:= _
            xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
            FROM:=1, OpenAfterPublish:=True

     End If

End Sub

Je suis totalement bloqué

Bonjour,

ci-jointe une proposition :

Sub DEVIS_SP_Pdf()
    Dim Mes_Docs As String, LeRep_devis As String
    Dim LeRepY As String, LeRepS As String, LaDate As String, LeNom As String, nom_fichier As String
    Dim DEVIS
    Dim sh_devis_ht As Worksheet, sh_devis_sp As Worksheet
    Dim Fso As Object, dossier As Object

    '// assignation feuilles devis
    Set sh_devis_ht = Sheets("DEVIS HT"): Set sh_devis_sp = Sheets("DEVIS SP")

    '// contrôles
    If sh_devis_ht.Range("H4") = "" Then MsgBox ("Il n'y a pas de numéro de devis !")
    If MsgBox("Voulez vous enregistrer le Devis sans prix en PDF ?", vbYesNo) = vbNo Then Exit Sub

    '// définition dossiers et nom du fichier
    LaDate = Format(Date, "ddmmyyyy")                                                   'Date du jour
    DEVIS = sh_devis_sp.Range("H4").Value                                               'Numero du devis
    Mes_Docs = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")              'Dossier mes documents
    LeRep_devis = Mes_Docs & "\Logiciel Devis\Devis SP\"                                'Repertoire des devis
    LeRepY = LeRep_devis & UCase(Format(sh_devis_sp.Range("H5").Value, "yyyy")) & "\"   'Repertoire des devis année
    LeRepS = LeRepY & UCase(Format(sh_devis_sp.Range("H5").Value, "ww-yyyy")) & "\"     'Repertoire des devis sp
    LeNom = sh_devis_ht.Range("G11").Value                                              'Nom du client
    nom_fichier = LeRepS & "\" & "SP-" & DEVIS & "-" & LeNom & "-" & LaDate

    '// création objet FilesSystem
    Set Fso = CreateObject("Scripting.FilesystemObject")

    '// création dossier / sous-dossier
    If Not Fso.FolderExists(LeRep_devis) Then MsgBox "répertoire devis inexistant": Exit Sub
    If Not Fso.FolderExists(LeRepY) Then Fso.CreateFolder (LeRepY)
    If Not Fso.FolderExists(LeRepS) Then Fso.CreateFolder (LeRepS): MsgBox "Le dossier " & LeRepS & " a été créé"

    '// création fichier PDF
    sh_devis_sp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nom_fichier & ".pdf", OpenAfterPublish:=True

    '// libération objet FilesSystem
    Set Fso = Nothing

End Sub

Bonjour,

Merci pour la réponse si rapide.

Pouvez vous me dire ou été mon erreur svp ?

Aussi, est ce que la macro fonctionne toujours si on change de PC ?

D'ou mon Environ("Username")

Salut,

J'ai pas tout vérifier mais bon sur ce bout de code

     If Dir(LeRepY, vbDirectory) = "" Then
            MkDir LeRepY
     ElseIf Dir(LeRepS, vbDirectory) = "" Then
            MkDir LeRepS
            MsgBox "Le dossier " & LeRepS & " a été crée"
     End If

VB va tester si LeRepY existe s'il n'existe pas il va le créer, mais ensuite il va sortir du If, donc pas de création du second répertoire. Un peu de lecture de chez Crosoft

Lors de l’exécution d’un bloc If (seconde syntaxe), la condition est testée. Si la condition est vrai, les instructions qui suivent Then sont exécutées. Si la condition est faux, chaque condition ElseIf (le cas échéant) est évaluée en séquence. Lorsqu’une condition vrai est trouvée, les instructions qui suivent immédiatement l’associé Then sont exécutées. Si aucune des conditions ElseIf sont vrai (ou s’il n’existe aucune clause ElseIf ), les instructions qui suivent Else sont exécutées. Après l’exécution des instructions suivant Then ou Else, l’exécution continue avec instruction suivant End If.

Maintenant évite les "\" en fin de chemin quand tu teste avec dir, petit test à faire dans la fenêtre d'exécution. (il ne renvoie pas le nom du répertoire)

? dir(thisworkbook.Path,vbDirectory)

? dir(thisworkbook.Path & "\",vbDirectory)

Aussi, est ce que la macro fonctionne toujours si on change de PC ?

Tout le monde n'a pas le répertoire User sous C: moi par exemple, donc problèmes assurés

re,

Petite fonction pour créer des répertoires en cascade, ce n'est pas de moi

' // CreateSubFolder By Philippe Tulliez le : 16/07/2021
' // Nom du ou des répertoires à créer. Il y a lieu de séparés par un délimiteur s'il y a plus d'un répertoir
Sub CreateSubFolder(FullPath As String, RootFolder As String, Optional Delimiter As String = "\")
    Dim PathName As String
    Dim Tbl As Variant
    Dim Elem As Byte

    Tbl = Split(FullPath, Delimiter)
    PathName = RootFolder
    For Elem = 0 To UBound(Tbl)
        PathName = PathName & Delimiter & Tbl(Elem)
        If Dir(PathName, vbDirectory) = vbNullString Then MkDir PathName
    Next
End Sub

Pouvez vous me dire ou été mon erreur svp ?
Pas vraiment car je n'ai pas testé votre code en l'état. Mais il est possible que le répertoire "\Logiciel Devis\Devis SP\" n'existe pas sous "Mes Documents" auquel cas if faut rajouter la création des dossiers parents. Comme ceci :

    '// création dossier / sous-dossier
    Dim répertoire As String
    répertoire = Mes_Docs & "\Logiciel Devis\"
    If Not Fso.FolderExists(répertoire) Then Fso.CreateFolder (répertoire)
    répertoire = répertoire & "\Devis SP\"
    If Not Fso.FolderExists(répertoire) Then Fso.CreateFolder (répertoire)

    If Not Fso.FolderExists(LeRepY) Then Fso.CreateFolder (LeRepY)
    If Not Fso.FolderExists(LeRepS) Then Fso.CreateFolder (LeRepS): MsgBox "Le dossier " & LeRepS & " a été créé"

Aussi, est ce que la macro fonctionne toujours si on change de PC ? D'ou mon Environ("Username")

Cette instruction fournit le chemin du dossier "Mes Documents quelque soit le PC :

Mes_Docs = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")

c 

Merci pour toutes ces réponses, je comprend mieux désormais

Une dernière question si je peux me permettre.

J'aimerais ajouter une condition d'enregistrement du fichier Excel, si je refuse l'édition PDF.

J'ai donc essayer de "remanier le code" mais je sèche

Bonsoir,

1- insérer ce code dans l'objet ThisWorkBook

Public édition_pdf As Boolean
Const mot_passe_enreg  As String = "provisoire"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim mot_passe

    If Not édition_pdf Then
        mot_passe = InputBox("Veuillez saisir le mot de passe pour enregistrer")
        If mot_passe <> mot_passe_enreg Then Cancel = True
    End If

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    If Not édition_pdf Then
        ThisWorkbook.Saved = True
        MsgBox "fichier non enregistré car pas de création de devis PDF"
    Else
        ThisWorkbook.Save
        MsgBox "fichier enregistré"
    End If

End Sub

2- ajouter cette instruction dans le code actuel'// création fichier PDF

    '// création fichier PDF
    sh_devis_sp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nom_fichier & ".pdf", OpenAfterPublish:=True

    '// activation sauvegarde fichier
    ThisWorkbook.édition_pdf = True

    '// libération objet FilesSystem
    Set Fso = Nothing

NB: Dans le cas d'un enregistrement avant fermeture, fourniture obligatoire d'un mot de passe ("provisoire" par défaut)

En fait ce que j'aimerais faire :

- Si on ne veut pas enregistrer en PDF, alors il demande si on veut enregistrer le classeur

- Si la la condition est vrai (Oui a l'enregistrement du classeur), alors il teste et créer les dossiers et sous dossiers (Répertoire identique a l'enregistrement en PDF)

J'ai donc essayer d'ajouter les lignes d'enregistrement du classeur aprés la condition d'enregistrement en PDF, mais il me dit qu'il me manque un Bloc IF ou End if, mais je ne trouve pas mon erreur.

1- insérer ce code dans l'objet ThisWorkBook

Public enreg_classeur As Boolean
Const mot_passe_enreg  As String = "provisoire"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim mot_passe

    If Not enreg_classeur Then
        mot_passe = InputBox("Veuillez saisir le mot de passe pour enregistrer")
        If mot_passe <> mot_passe_enreg Then Cancel = True
    End If

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    If Not enreg_classeur Then
        ThisWorkbook.Saved = True
        MsgBox "classeur non enregistré"
    Else
        ThisWorkbook.Save
        MsgBox "classeur enregistré"
    End If

End Sub

2- ajouter ces instructions dans le code actuel

A-

    '// contrôles
    If sh_devis_ht.Range("H4") = "" Then MsgBox ("Il n'y a pas de numéro de devis !")

    Dim enreg_pdf As Boolean: enreg_pdf = True
    If MsgBox("Voulez vous enregistrer le Devis sans prix en PDF ?", vbYesNo) = vbNo Then
        enreg_pdf = False
        If MsgBox("Voulez vous enregistrer le classeur ?", vbYesNo) = vbYes Then
            ThisWorkbook.enreg_classeur = True
        Else
            Exit Sub
        End If
    End If

B-

    
    '// création fichier PDF
    If enreg_pdf Then sh_devis_sp.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nom_fichier & ".pdf", OpenAfterPublish:=True

NB: Dans le cas d'un enregistrement avant fermeture, fourniture obligatoire d'un mot de passe ("provisoire" par défaut)

En fait je n'ai pas besoin de préciser un mot de passe, je souhaiterais juste que le classeur s'enregistre avec le meme nom et au meme endroit que le fichier pdf qui aurait pu etre généré

En fait je n'ai pas besoin de préciser un mot de passe
Le mot de passe offre une protection au cas où un utilisateur essaierait d'enregistrer le classeur sans passer par la macro, en cliquant sur le bouton "enregistrer" par xemple.

Si vous estimez ne pas en avoir besoin, vous n'avez qu'à l'enlever en supprimant la procédure événementielle :

Private Sub Workbook_BeforeSave

Ah super, je n'avais pas vu cela comme ca, mais effectivement cela est nécessaire.

Merci beacoup

Encore désolé, mais j'ai une erreur de compilation sur :

ThisWorkbook.enreg_classeur = True

Avez-vous bien déclaré la variable publique "enreg_classeur" dans le code associé à l'objet ThisWorkBook

Public enreg_classeur As Boolean
Const mot_passe_enreg  As String = "provisoire"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim mot_passe

Oui j'ai bien fait le copier/coller.

Voici le code utilisé (j'ai adapter a la feuille Devis HT)

Sub DEVISHT_Pdf()
    Dim Mes_Docs As String, LeRep_devis As String
    Dim LeRepY As String, LeRepm As String, LaDate As String, LeNom As String, nom_fichier As String
    Dim DEVIS
    Dim sh_devis_ht As Worksheet
    Dim Fso As Object, dossier As Object

    '// assignation feuilles devis
    Set sh_devis_ht = Sheets("DEVIS HT")

    '// contrôles
        If sh_devis_ht.Range("H4") = "" Then MsgBox ("Il n'y a pas de numéro de devis !")

       Dim enreg_pdf As Boolean: enreg_pdf = True
            If MsgBox("Voulez vous enregistrer le Devis en PDF ?", vbYesNo) = vbNo Then
                enreg_pdf = False
            If MsgBox("Voulez vous enregistrer le classeur ?", vbYesNo) = vbYes Then
                ThisWorkbook.enreg_classeur = True
            Else
            Exit Sub
        End If
    End If

        '// définition dossiers et nom du fichier
        LaDate = Format(Date, "ddmmyyyy")                                                   'Date du jour
        DEVIS = sh_devis_ht.Range("H4").Value                                               'Numero du devis
        Mes_Docs = CreateObject("WScript.Shell").SpecialFolders("MyDocuments")              'Dossier mes documents
        LeRep_devis = Mes_Docs & "\Logiciel Devis\Devis\"                                   'Repertoire des devis
        LeRepY = LeRep_devis & UCase(Format(sh_devis_ht.Range("H5").Value, "yyyy")) & "\"   'Repertoire des devis année
        LeRepm = LeRepY & UCase(Format(sh_devis_ht.Range("H5").Value, "MMMM-yyyy")) & "\"   'Repertoire des devis sp
        LeNom = sh_devis_ht.Range("G11").Value                                              'Nom du client
        nom_fichier = LeRepm & "\" & "D1-" & DEVIS & "-" & LeNom & "-" & LaDate

        '// création objet FilesSystem
        Set Fso = CreateObject("Scripting.FilesystemObject")

        '// création dossier / sous-dossier
        If Not Fso.FolderExists(LeRep_devis) Then MsgBox "répertoire devis inexistant": Exit Sub
        If Not Fso.FolderExists(LeRepY) Then Fso.CreateFolder (LeRepY)
        If Not Fso.FolderExists(LeRepm) Then Fso.CreateFolder (LeRepm): MsgBox "Le dossier " & LeRepm & " a été créé"

        '// création fichier PDF

        If enreg_pdf Then sh_devis_ht.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nom_fichier & ".pdf", OpenAfterPublish:=True
        '// libération objet FilesSystem
        Set Fso = Nothing

End Sub

Salut Rafu59,

Je pense que vous ne répondez pas à la question de thev.

Faites un aperçus d'écran du Module ThisWorkBook. Car comme lui je pense que cette variable n'est pas déclarée.

Autant pour moi :

Public enreg_classeur As Boolean
Const mot_passe_enreg  As String = "provisoire"

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    Dim mot_passe

    If Not enreg_classeur Then
        mot_passe = InputBox("Veuillez saisir le mot de passe pour enregistrer")
        If mot_passe <> mot_passe_enreg Then Cancel = True
    End If

End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)

    If Not enreg_classeur Then
        ThisWorkbook.Saved = True
        MsgBox "classeur non enregistré"
    Else
        ThisWorkbook.Save
        MsgBox "classeur enregistré"
    End If

End Sub

Salut,
C'est quand même très bizarre cette histoire. Combien as-tu de classeurs ouvert quand tu lances cette macro ?

Il serait bien que l'on ai un fichier pour bien se rendre compte des problèmes.