Code VBA pour enregistrer fichier en pdf et en xlsm

Bonsoir,

Ayant créé un devis excel, j'ai inséré un bouton pour que mon fichier s'enregistre en pdf sous la forme DEVIS+NOM DU CLIENT

Voici mon code :

Sub DEVIS()

Dim nompdf As String

Dim dossier As String

Dim sh As Worksheet

Set sh = Worksheets("DEVIS")

dossier = ThisWorkbook.Path

'masque les colonnes B et E

sh.Range("B:B,E:E").EntireColumn.Hidden = True

nompdf = dossier & "\" & "Devis" & ActiveSheet.Range("h13")

sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=nompdf & ".pdf", _

Quality:=xlQualityStandard, IncludeDocProperties:=True, _

IgnorePrintAreas:=False, OpenAfterPublish:=True

'affiche les colonnes B et E

sh.Range("B:B,E:E").EntireColumn.Hidden = False

End Sub

Le code fonctionne mais je souhaiterais l'améliorer, à savoir :

1) choisir le chemin pour que le fichier PDF s'enregistre dans mon dossier DEVIS et non sur le bureau

2) actuellement, si un devis existe déjà pour ce client, il est effacé par le nouveau ; je souhaiterais qu'il incrémente un nouveau nom avec DEVISNOM2 par exemple

3) je souhaiterais également que mon document s'enregistre aussi en xlsm dans un fichier DEVISEXCEL également avec incrémentation, ceci afin de pouvoir y apporter d'éventuelles modifications

4) Enfin, j'aimerais que mon document DEVIS de base se ferme sans enregistrer les modifications

Je suis novice en VBA et j'essaie, comme beaucoup de débutants je pense, de copier et adapter des codes créés par des experts mais ce n'est pas toujours évident à comprendre.

Je vous remercie de votre aide et du temps que vous voudrez bien me consacrer,

Je suis novice en VBA et j'essaie, comme beaucoup de débutants je pense, de copier et adapter des codes créés par des experts mais ce n'est pas toujours évident à comprendre.

Je vous remercie de votre aide et du temps que vous voudrez bien me consacrer,

Bonjour choupie972,

je pense que si tu veux vraiment apprendre le langage vba, il vaux mieux posé une question à la fois

pour mieux comprendre la réponse.

par exemple:

1) choisir le chemin pour que le fichier PDF s'enregistre dans mon dossier DEVIS et non sur le bureau

le code pour choisir le répertoire:

Dim FD As FileDialog, oFolder As Object

Set FD = Application.FileDialog(msoFileDialogFolderPicker)
With FD
    .AllowMultiSelect = False
    .Show
    oFolder = .SelectedItems(1) 
    Debug.Print oFolder    'preuve du chemin choisi: s'affiche sur la fenêtre exécution
End With

dans ton code tu utilise

nompdf = dossier & "\" & "Devis" & ActiveSheet.Range("h13")

il faudra remplacer

dossier

par

oFolder

Bonjour à tous,

deux petits conseils pour enregistrer au format PDF.

Si le chemin est toujours le même on peut l'écrire directement dans le code.

Pour vérifier si le nom de fichier existe et le changer si nécessaire, j'ai adapté deux fonctions.

Voici un exemple à tester:

Sub DEVIS()
    'https://forum.excel-pratique.com/viewtopic.php?f=2&t=130216

    Dim nompdf As String
    Dim dossier As String
    Dim sh     As Worksheet

    Set sh = Worksheets("DEVIS")
    dossier = "C:\Users\Username\Desktop\Devis\"     '<<=============Chemin à adapter
    Application.ScreenUpdating = False

    'masque les colonnes B et E
    sh.Range("B:B,E:E").EntireColumn.Hidden = True

    nompdf = "Devis " & ActiveSheet.Range("H13") & ".pdf"

    nompdf = FileNameUnique(dossier, nompdf, ".pdf")
    sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=dossier & nompdf, _
                           Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                           IgnorePrintAreas:=False, OpenAfterPublish:=False

    'affiche les colonnes B et E
    sh.Range("B:B,E:E").EntireColumn.Hidden = False
    Application.ScreenUpdating = True

End Sub

Private Function FileNameUnique(strPath As String, _
        strFilename As String, _
        strExtension As String) As String
    'by Graham Mayor - www.gmayor.com/
    Dim lngF   As Long
    Dim lngName As Long
    strExtension = Replace(strExtension, Chr(46), "")
    'lngF = 1
    lngF = 2

    lngName = Len(strFilename) - (Len(strExtension) + 1)
    strFilename = Left(strFilename, lngName)
    'If the filename exists, add or increment a number to the filename
    'and keep checking until a unique name is found
    Do While FileExists(strPath & strFilename & Chr(46) & strExtension) = True
        '        strFilename = Left(strFilename, lngName) & "(" & lngF & ")"
        strFilename = Left(strFilename, lngName) & " " & lngF

        lngF = lngF + 1
    Loop
    'Reassemble the filename
    FileNameUnique = strFilename & Chr(46) & strExtension
lbl_Exit:
    Exit Function
End Function

Private Function FileExists(strFullName As String) As Boolean
    'by Graham Mayor - www.gmayor.com/
    'strFullName is the name with path of the file to check
    Dim fso    As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FileExists(strFullName) Then
        FileExists = True
    Else
        FileExists = False
    End If
lbl_Exit:
    Set fso = Nothing
    Exit Function
End Function

Bonsoir Sequoyah,

Génial !!!

Ca fonctionne à merveille ! Je te remercie beaucoup.

J'avoue que j'étais désorientée par la réponse de i20100 et je n'arrivais pas à comprendre pourquoi il fallait tout modifier.

Ta réponse est plus lisible pour moi et correspond tout à fait à ce que je souhaitais obtenir.

Sans vouloir abuser, pourrais-tu te pencher sur la question relative à l'enregistrement xlsm et à l'enregistrement stp ?

3) je souhaiterais également que mon document s'enregistre aussi en xlsm dans un fichier DEVISEXCEL également avec incrémentation, ceci afin de pouvoir y apporter d'éventuelles modifications

4) Enfin, j'aimerais que mon document DEVIS de base se ferme sans enregistrer les modifications

Est-il possible d'adapter simplement le code que tu m'as proposé en y incluant les paramètres relatifs à EXCEL ou est-ce plus compliqué ?

Je te remercie pour ton aide précieuse,

Bonsoir choupie972,

merci pour ton retour, voici le nouveau code de la macro, les deux fonctions ne changent pas:

Sub DEVIS2()

    Dim nompdf As String, NomXl As String
    Dim dossier As String, dossierXl As String
    Dim sh     As Worksheet
    Dim Wkb    As Workbook

    Set sh = Worksheets("DEVIS")
    dossier = "C:\Users\Username\Desktop\Devis\"     '<<=============Chemin à adapter
    dossierXl = "C:\Users\Username\Desktop\DevisExcel\"     '<<=============Chemin à adapter

    Application.ScreenUpdating = False

    'masque les colonnes B et E
    sh.Range("B:B,E:E").EntireColumn.Hidden = True

    nompdf = "Devis " & ActiveSheet.Range("H13") & ".pdf"
    NomXl = "Devis " & ActiveSheet.Range("H13") & ".xlsx"

    nompdf = FileNameUnique(dossier, nompdf, ".pdf")
    sh.ExportAsFixedFormat Type:=xlTypePDF, Filename:=dossier & nompdf, _
                           Quality:=xlQualityStandard, IncludeDocProperties:=True, _
                           IgnorePrintAreas:=False, OpenAfterPublish:=False

    'affiche les colonnes B et E
    sh.Range("B:B,E:E").EntireColumn.Hidden = False

    'Création et enregistrement nouveau fichier
    sh.Copy
    NomXl = FileNameUnique(dossierXl, NomXl, ".xlsx")
    ActiveWorkbook.SaveAs dossierXl & NomXl
    ActiveWorkbook.Close

    Application.ScreenUpdating = True

    ThisWorkbook.Close savechanges:=False
End Sub

Hello Sequoyah,

Encore merci pour ton aide,

C'est presque parfait, à un détail près que tu ne pouvais pas deviner puisque je ne t'ai pas transmis mon fichier,

En fait, mon document DEVIS comporte plusieurs onglets avec des liaisons entre eux et l'enregistrement du devis excel ne prend en compte que la page active. Je ne peux donc pas modifier le devis ultérieurement en cas de besoin.

Comment faire pour que l'enregistrement prenne en compte les différents onglets ?

Merci encore de ton aide vraiment précieuse,

Bonjour choupie972,

change la ligne:

sh.Copy

avec

Sheets(Array("DEVIS", "Recap", "Onglet")).Copy ' à adapter le nom des onglets

Merciii beaucoup Sequoyah,

Tout est parfait, exactement comme je voulais,

A présent, je m'attaque à l'envoi du devis pdf par mail... je vais m'inspirer des conseils que tu as donnés à d'autres utilisateurs,

Merci encore, je ne manquerai pas de t'appeler à l'aide en cas de besoin,

Bonne journée à toi

Bonsoir,

Grace à l'aide de Sequoyah, mon fichier fonctionnait parfaitement.

J'ai fait plusieurs améliorations et lors de la dernière, patatras… impossible de rouvrir mon fichier..

J'ai donc désactivé les macros dans les options d'Excel afin de pouvoir supprimer le morceau de code qui posait problème.

Ca a bien fonctionné et je pensais avoir résolu le problème.

Malheureusement, lors de la tentative d'enregistrement suivante, message d'erreur comme quoi "les fonctionnalités suivantes ne peuvent pas être enregistrées dans des classeurs sans macro : Projet VB"

Je précise que j'avais bien réactivé les macros dans les options d'Excel.

Le débogage pointe sur la ligne :

ActiveWorkbook.SaveAs dossierXl & nomXl

sachant que le nomXl est défini ainsi

nomXl = FileNameUnique(dossierXl, nomXl, ".xlsm")

Je pense que le problème doit venir de la fonction FileNameUnique qui fonctionnait jusqu'ici.

Par contre, je ne comprends pas du tout cette fonction et je ne sais que faire pour remédier à mon problème.

Cette fonction est dans la réponse de Sequoyah du 29sept.

Merci de votre aide,

Bonjour choupie972,

je pense que le problème n'est pas dans la fonction mais dans le fait que dans mon code l'extension du fichier Excel à enregistrer est au format .xlsx et non .xlsm (format de fichier prenant en charge les macros).

Cordialement.

Bonjour Sequoyah,

Merci de ta réponse rapide,

Avant mon bug, tout marchait nickel et j'avais laissé .xlsx

Ensuite, quand il a refusé de m'enregistrer mes fichiers excel, j'ai tenté de modifier en remplaçant .xlsx par .xlsm mais ça ne fonctionne pas mieux.

Aurais-tu une idée pour résoudre ce problème ?

Peut-être supprimer l'enregistrement du fichier excel, enregistrer et ressaisir ensuite le code pour l'enregistrement excel ?

Penses-tu que cela pourrait résoudre mon problème ?

Merci encore de ton aide,

Sequoyah,

Oups, je viens de réaliser qu'effectivement, tous mes devis enregistrés sous excel ne supportent pas les macros et sont donc inutilisables en l'état.

En fait, je souhaiterais enregistrer mes devis en pdf pour envoyer au client et en xlsm pour pouvoir ensuite les transformer en facture.

Comment faire pour que je ne sois pas obligée de retaper mon devis pour le transformer en facture ou pour le modifier ?

Aurais-tu une suggestion ?

Merci de ton aide,

Bonjour,

le fait que les fichiers ne soient pas au format xlsm ne devrait pas empêcher la transformation en facture, tu dois mieux spécifier comment tu fais le passage du devis à la facture.

Edit:

Pour enregistrer au format .xlsm change la ligne:

ActiveWorkbook.SaveAs dossierXl & NomXl

par:

 ActiveWorkbook.SaveAs dossierXl & NomXl, FileFormat:=xlOpenXMLWorkbookMacroEnabled

Le problème vient du fait que tout se fait par macro.

J'ai un bouton d'appel de userform sur mon document devis et je choisis ensuite ce que je veux faire : soit un devis soit une facture.

Mais forcément, quand je reviens sur mon document devis excel, les macros sont désactivées et donc impossible d'avoir accès au userform.

J'avoue que je bloque un peu sur la façon de faire.

Bonjour choupie972,

j'ai changé dans mon dernier post le code pour la sauvegarde du classeur au format .xslm, on peut ensuite glisser-déposer le userform dans le nouveau fichier ou exporter le userform avec le code suivant (à adapter les noms du fichier et du userform):

A' cocher dans les paramètres des macros Accès approuvé au modèle d'objet du projet VBA.

Sub ImportForm()

    Dim wbSource As Workbook, wbDestination As Workbook

    Set wbSource = ThisWorkbook
    Set wbDestination = Workbooks("DEVIS - 2.xlsm") 'A' adapter

    wbSource.VBProject.VBComponents("UserForm1").Export "UserForm1.frm"

    wbDestination.VBProject.VBComponents.Import "UserForm1.frm"

    Kill "UserForm1.frm"
    Kill "UserForm1.frx"

End Sub

Alors, j'ai changé le code comme tu m'as indiqué,

A présent, les devis excel s'enregistrent bien en xlsm

Par contre, lorsque je retourne sur un devis pour le modifier ou le transformer en facture, j'ai un message d'erreur qui vient du fait que mon userform de validation n'est pas enregistré dans les vba objects de mon nouveau document.

Est-ce un problème d'enregistrement du userform ? Y a t il un paramètre à définir pour qu'il s'enregistre avec le nouveau document ?

Merci encore de ton aide et du temps que tu me consacres,

Oups, nos messages se sont croisés…

Je me penche de suite sur ta réponse,

Merci

Désolée de t'embêter encore,

J'ai un souci avec le nom à renseigner dans le wbDestination,

J'ai essayé comme ça mais ça ne fonctionne pas :

'création et enregistrement fichier excel

Sheets(Array("DEVIS", "DETAIL PRESTATIONS", "CLIENTS", "CHRONO DEVIS")).Copy

nomXl = FileNameUnique(dossierXl, nomXl, ".xlsm")

ActiveWorkbook.SaveAs dossierXl & nomXl, FileFormat:=xlOpenXMLWorkbookMacroEnabled

Dim wbSource As Workbook, wbDestination As Workbook

Set wbSource = ThisWorkbook

Set wbDestination = Workbooks(FileNameUnique(dossierXl, nomXl, ".xlsm")

wbSource.VBProject.VBComponents.Import "UserForm4.frm"

Kill "UserForm4.frm"

Kill "UserForm4.frx"

ActiveWorkbook.Close

Apparemment, je n'ai pas renseigné le bon nom dans wbDestination

Re-bonjour choupie972,

peux-tu joindre un fichier exemple, sans données confidentielles?

Aujourd'hui, je dois quitter mais je vais voir ça dans les prochains jours.

A' tester:

    'Création et enregistrement nouveau fichier
    Sheets(Array("DEVIS", "DETAIL PRESTATIONS", "CLIENTS", "CHRONO DEVIS")).Copy
    NomXl = FileNameUnique(dossierXl, NomXl, ".xlsm")

    ThisWorkbook.VBProject.VBComponents("UserForm1").Export "UserForm4.frm"
    ActiveWorkbook.VBProject.VBComponents.Import "UserForm4.frm"

    Kill "UserForm4.frm"
    Kill "UserForm4.frx"

    ActiveWorkbook.SaveAs dossierXl & NomXl, FileFormat:=xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close
Rechercher des sujets similaires à "code vba enregistrer fichier pdf xlsm"