Exporter un PDF avec un nom de fichier précisé une cellule

Bonjour.

J'ai une macro qui me permet d'enregistrer en PDF, mais j'aimerais que le fichier enregistré porte le nom contenu dans une cellule, et qu'il soit enregistré dans un dossier précis. Voici la macro existante :

Sub CreerPDF()

Dim sRep As String

Dim sFilename As String

Sheets(Array("Devis", "Matériel", "Mensualités")).Select

sRep = ThisWorkbook.Path

sFilename = ThisWorkbook.Name

sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"

ActiveSheet.ExportAsFixedFormat _

Type:=xlTypePDF, _

Filename:=sRep & sFilename, _

Quality:=xlQualityStandard, _

IncludeDocProperties:=True, _

IgnorePrintAreas:=False, _

OpenAfterPublish:=True

End Sub

Salut,

Modifie les lignes que j'ai surligné pour les adapter à tes besoins.

Sub CreerPDF()
    Dim sRep As String
    Dim sFilename As String

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select
    sRep = "D:\"   'Mettre le nom de l'emplacement souhaité entre guillemets par exemple "D:\"
    sFilename = ActiveSheet.Range("A1").Value   'Remplacer A1 par le nom de la cellule voulu pour le nom du fichier
    sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"

    ActiveSheet.ExportAsFixedFormat _
    Type:=xlTypePDF, _
    Filename:=sRep & sFilename, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=True
End Sub

Skiinck

Merci pour ta réponse, mais cela ne fonctionne pas encore :

1) Le système ne me l'enregistre pas à l'endroit voulu. Il me l'enregistre comme d'habitude ici : \\PC-BLEU\Google Drive\Hors cours

Tu noteras que PC-BLEU est un NAS.

2) Il ne me prend pas le nom du fichier qui est indiqué dans la cellule H1, mais continue à l'enregistrer avec un nom formé par la concaténation du nom du dossier et du nom du fichier Excel.

En plus, ce serait bien que la macro prenne le contenu de la cellule H1 de la page Devis, plutôt que celui de la feuille active.

Sub CreerPDF()
    Dim sRep As String
    Dim sFilename As String

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = ActiveSheet.Range("H1").Value
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    sRep = ThisWorkbook.Path
    sFilename = ThisWorkbook.Name
    sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select

End Sub

Tu as oublié de supprimer les deux lignes surlignées ci-dessous :

Sub CreerPDF()
    Dim sRep As String
    Dim sFilename As String

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = ActiveSheet.Range("H1").Value
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    sRep = ThisWorkbook.Path
    sFilename = ThisWorkbook.Name
    sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select

End Sub

En fait ce que tu as remplacé est bien prit en compte mais est de nouveau remplacé par ce qu'il y avait avant !

Pour prendre la cellule H1 de la page Devis :

ThisWorkbook.Worksheets("Devis").Range("H1").Value

Code finale :

Sub CreerPDF()
    Dim sRep As String
    Dim sFilename As String

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = ThisWorkbook.Worksheets("Devis").Range("H1").Value
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select

End Sub

Il y a aussi la possibilité de choisir à chaque fois où est enregistré le fichier ! Mais ça je n'ai pas encore les connaissances pour le faire...

Skiinck

Cela commence à bien marcher ! Dire que cela fait 3 ans que je fais toutes ces manipulations !

J'ai juste ajouté un petit \ à la fin de cette ligne :

sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients\"

Par contre,

1) La macro tronque le contenu de ma cellule H1, lorsqu'il rencontre un point; comment éviter cela ?

2) Le fichier créé écrase le fichier existant du même nom ; il faudrait une confirmation.

Voici donc le fichier actuel :

Sub Creer_un_devis_PDF()

    Dim sRep As String
    Dim sFilename As String

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients\"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = ThisWorkbook.Worksheets("Devis").Range("H1").Value
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select

End Sub

Bien vu pour la petite erreur je n'avais pas fait attention

J'ai remarqué que la ligne ci-dessous ne servait en fait à rien puisque le nom d'extension est déjà défini lors de la création du fichier.

sFilename = Left(sFilename, InStr(1, sFilename, ".")) & "pdf"

J'ai refais le code en ajoutant une confirmation et la possibilité de changer le nom du fichier qui par défaut est celle de la cellule H1. Si tu préfère ne pas pouvoir changer le nom alors il suffit de remettre ce qu'il y avait avant !

Voici ce que ça donne :

Sub Creer_un_devis_PDF()

    Dim sRep As String
    Dim sFilename As String
    Dim FichierExistant As Boolean

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients\"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = InputBox("Veuillez renseigner un nom de fichier :", "Nom de fichier", ThisWorkbook.Worksheets("Devis").Range("H1").Value)
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    If sFilename = "" Then Exit Sub
    'Sort de la macro si aucun nom n'a été donné ou que Annuler a été choisit précédemment

    FichierExistant = (Dir(sRep & sFilename & ".pdf") <> "")
    'La variable devient Vrai si le fichier existe

    If FichierExistant = True And MsgBox("Le fichier existe déjà, voulez-vous le remplacer ?", vbYesNo, "Demande de confirmation") = vbNo Then Exit Sub
    'Vérifie et demande une confirmation si il y a déjà un fichier du même nom

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select

End Sub

Est-ce qu'il y a encore le problème avec les points ?

Skiinck

Bonjour et merci pour ta réponse !

C'est presque parfait ! Il y a juste encore un petit pépin : il m'alerte que le fichier existe déjà, même lorsqu'il n'existe pas.

Tu verras dans le code actuel, que j'ai enlevé la possibilité de modifier le nom du fichier, car justement j'aime bien que le plus de choses soient automatiques, pour gagner du temps…

Sinon, je suis vraiment impressionné par les possibilités des macros ; je connaissais une partie de leurs possibilités, mais je n'avais pas encore mis autant en pratique !

À bientôt, et passe une bonne matinée !

Sub Creer_un_devis_PDF()

    Dim sRep As String
    Dim sFilename As String
    Dim FichierExistant As Boolean

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients\"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = ThisWorkbook.Worksheets("Devis").Range("J1").Value
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    'sFilename = InputBox("Veuillez renseigner un nom de fichier :", "Nom de fichier", ThisWorkbook.Worksheets("Devis").Range("J1").Value)
    'Cette ligne permet de saisir un autre nom de fichier, sinon c'est le texte de la cellule J1 qui est pris.

    If sFilename = "" Then Exit Sub
    'Sort de la macro si aucun nom n'a été donné ou que Annuler a été choisit précédemment

    FichierExistant = (Dir(sRep & sFilename & ".pdf") <> "")
    'La variable devient Vrai si le fichier existe

    If FichierExistant = True And MsgBox("Le fichier existe déjà, voulez-vous le remplacer ?", vbYesNo, "Demande de confirmation") = vbNo Then Exit Sub
    'Vérifie et demande une confirmation si il y a déjà un fichier du même nom

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select

End Sub

Salut,

Oui c'est normal si il demande à chaque fois, c'est parce que le If vérifie 2 conditions en même temps, j'aurais dû le faire en deux ligne

J'ai volontairement mis la possibilité de choisir l'emplacement pour te montrer des possibilités !

Sub Creer_un_devis_PDF()

    Dim sRep As String
    Dim sFilename As String
    Dim FichierExistant As Boolean

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients\"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = ThisWorkbook.Worksheets("Devis").Range("J1").Value
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    'sFilename = InputBox("Veuillez renseigner un nom de fichier :", "Nom de fichier", ThisWorkbook.Worksheets("Devis").Range("J1").Value)
    'Cette ligne permet de saisir un autre nom de fichier, sinon c'est le texte de la cellule J1 qui est pris.

    If sFilename = "" Then Exit Sub
    'Sort de la macro si aucun nom n'a été donné ou que Annuler a été choisit précédemment

    FichierExistant = (Dir(sRep & sFilename & ".pdf") <> "")
    'La variable devient Vrai si le fichier existe

    If FichierExistant = True Then 
        If MsgBox("Le fichier existe déjà, voulez-vous le remplacer ?", vbYesNo, "Demande de confirmation") = vbNo Then Exit Sub
    End If
    'Vérifie et demande une confirmation si il y a déjà un fichier du même nom

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select

End Sub

Skiinck

Encore quelques petites améliorations :

1) Si le fichier existe, et que je réponds non, il faudrait que la macro aille à la dernière instruction de la macro, pour sélectionner la feuille « devis » ; cela m'évite de faire des erreurs, en ayant toujours les 3 feuilles sélectionnées…

2) Je dois envoyer le devis par mail, et ce serait donc mieux d'ajouter, à la fin de la macro, une instruction qui copie l'adresse mail se trouvant dans la case D14 de la feuille "devis", afin que je n'aie plus qu'à la coller dans le mail.

En tout cas, un grand merci pour ton aide précieuse ! Je comprends 95 % de ce que tu écris dans la macro, mais actuellement je serais incapable de l'écrire…

1) Plutôt que de rajouter du code pour aller à la dernière ligne, autant l'ajouter directement avant de quitter la macro

ThisWorkbook.WorkSheets("Devis").Select

Mettre "ThisWorkbook" devant n'est pas obligatoire mais je préfère ça peux éviter des problèmes parfois !

(Perso je ne comprend pas à 100% la fonction "Array" du coup je l'utilise pas trop)

2) Pour copier un case c'est simplement la fonction "Copy" et comme on sélectionne la feuille "Devis" déjà avant, on peut utiliser la fonction "ActiveSheet" (au lieu de "ThisWorkbook.WorkSheets("Devis")")

ActiveSheet.Range("D14").Copy

Résultat :

Sub Creer_un_devis_PDF()

    Dim sRep As String
    Dim sFilename As String
    Dim FichierExistant As Boolean

    Sheets(Array("Devis", "Matériel", "Mensualités")).Select

    sRep = "\\PC-BLEU\Google Drive\Hors cours\Devis - Clients\"
    'Mettre le nom de l'emplacement souhaité.

    sFilename = ThisWorkbook.Worksheets("Devis").Range("J1").Value
    'Mettre le nom de la cellule voulu pour le nom du fichier.

    'sFilename = InputBox("Veuillez renseigner un nom de fichier :", "Nom de fichier", ThisWorkbook.Worksheets("Devis").Range("J1").Value)
    'Cette ligne permet de saisir un autre nom de fichier, sinon c'est le texte de la cellule J1 qui est pris.

    If sFilename = "" Then Exit Sub
    'Sort de la macro si aucun nom n'a été donné ou que Annuler a été choisit précédemment

    FichierExistant = (Dir(sRep & sFilename & ".pdf") <> "")
    'La variable devient Vrai si le fichier existe

    If FichierExistant = True Then 
        If MsgBox("Le fichier existe déjà, voulez-vous le remplacer ?", vbYesNo, "Demande de confirmation") = vbNo Then 
            ThisWorkbook.WorkSheets("Devis").Select
            Exit Sub
        End If
    End If
    'Vérifie et demande une confirmation si il y a déjà un fichier du même nom

    ActiveSheet.ExportAsFixedFormat _
            Type:=xlTypePDF, _
            Filename:=sRep & sFilename, _
            Quality:=xlQualityStandard, _
            IncludeDocProperties:=True, _
            IgnorePrintAreas:=False, _
            OpenAfterPublish:=True

    Sheets(Array("Devis")).Select
    ActiveSheet.Range("D14").Copy

End Sub

Skiinck

La macro marche vraiment très bien ! C'est vraiment très sympa de ta part de m'avoir aidé.

Je te souhaite une bonne fin d'après-midi.

Message supprimé.

Salut,

Pour un nouveau problème, il vaut mieux créer un nouveau topic

J'ai pas le temps de t'aider pour l'instant désolé

A+

Ok Merci.