Microsoft 365 Code VBA pour imprimer en pdf

[Adelme]

Bonjour
Ne connaissant rien au VBA j'aimerais une macro qui renomme le fichier Excel et qui imprime en pdf une sélection d'onglets de mon fichier Excel en fonction de la valeur de certaines cellules.

Je m'explique : j'ai 3 onglets nommés 1, 2 et 3. Dans l'onglet 1 il y a 2 cellules (A1 et A2) qui valent chacune soit 0 soit 1. J'aimerais que la macro :
1) sauvegarde le fichier Excel dans le même répertoire avec comme nouveau nom la valeur de la cellule B5 de l'onglet 1
2) imprime en pdf :
- les onglets 1 et 2 lorsque les cellules A1 = 1 et A2 = 0
- les onglets 1 et 3 lorsque les cellules A1 = 0 et A2 = 1
- les onglets 1, 2 et 3 lorsque les cellules A1 = 1 et A2 = 1
3) enregistre le pdf dans le même répertoire que le fichier Excel et qu'il soit nommé comme le contenu de la cellule B5 de l'onglet 1

Quelqu'un peut il m'aider? Merci d'avance !

 

[kiki29]

Salut, n'étant pas un partisan du "tout cuit", voir ici ainsi que la remarque là et adapter à ton contexte

 

[Adelme]

Merci Kiki29 pour ta réponse rapide.
Le code fonctionne très bien, il permet de renommer le fichier excel et d'imprimer en pdf les 3 premières feuilles de mon excel.
Par contre j'aimerais qu'il imprime au choix que certaines feuilles en fonction de la valeur de certaines cellules.
J'aimerais également que le fichier excel s'enregistre automatiquement dans le même répertoire d'origine et qu'à la fin de la macro le fichier excel reste ouvert.
Je suppose que c'est possible de faire tout ça mais comment ?
Merci pour votre aide !

 

[kiki29]

re, n'étant pas un partisan du "tout cuit", à toi de poursuivre et adapter à ton contexte

Option Explicit

Sub EnregistrerSous()
Dim sNomfichier As String, sExt1 As String, sExt2 As String
Dim sChemin As String, oNomFichier As Variant
Dim pos As Long, sFichierFinal As String, Ar() As String

    ChDir ThisWorkbook.Path

    sNomfichier = Feuil1.Range("B5")
    sExt1 = ".xlsm"
    sExt2 = ".pdf"
    If NomFichierValide(sNomfichier) = False Then
        Feuil1.Range("B5").Select
        MsgBox "Nom de fichier invalide !", vbCritical + vbOKOnly
        Exit Sub
    End If

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sNomfichier, _
                                                fileFilter:="Fichiers Excel (*" & sExt1 & ", *" & sExt1)
    If oNomFichier <> False Then
        pos = InStrRev(oNomFichier, "\")
        sChemin = Left$(oNomFichier, pos - 1)
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt1)

        ReDim Ar(1) As String
        If Feuil1.Range("A1") = 1 And Feuil1.Range("A2") = 0 Then
            Ar(0) = Feuil1.Name
            Ar(1) = Feuil2.Name
        End If
        If Feuil1.Range("A1") = 0 And Feuil1.Range("A2") = 1 Then
            Ar(0) = Feuil1.Name
            Ar(1) = Feuil3.Name
        End If
        If Feuil1.Range("A1") = 1 And Feuil1.Range("A2") = 1 Then
            ReDim Ar(2) As String
            Ar(0) = Feuil1.Name
            Ar(1) = Feuil2.Name
            Ar(2) = Feuil3.Name
        End If
        If Feuil1.Range("A1") = 0 And Feuil1.Range("A2") = 0 Then
            MsgBox "Aucune feuille de sélectionnée !", vbCritical + vbOKOnly
            Feuil1.Range("A1").Select
            Exit Sub
        End If

        ThisWorkbook.SaveCopyAs Filename:=sFichierFinal
  
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
        Sheets(Ar).Select
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=sFichierFinal, _
                                        Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, _
                                        IgnorePrintAreas:=False, _
                                        OpenAfterPublish:=True
        Feuil1.Select
        Erase Ar
    End If
End Sub

 

[Adelme]

Bonjour Le Forum,

Je progresse mais ce n'est pas encore ça pour mes premiers pas en VBA.
Voici mon code en entier que j'ai adapté en remplaçant Feuil par Sheet et en modificant les cellules à cibler.
Le code plante au tout début sur ChDir ThisWorkbook.Path
Le message d'erreur dit "erreur 76 path not found".

Je n'arrive pas à comprendre pourquoi ça plante.

Merci !

Option Explicit

Sub PrintPDF()
Dim sNomfichier As String, sExt1 As String, sExt2 As String
Dim sChemin As String, oNomFichier As Variant
Dim pos As Long, sFichierFinal As String, Ar() As String

    ChDir ThisWorkbook.Path

    sNomfichier = Sheet1.Range("Z6")
    sExt1 = ".xlsm"
    sExt2 = ".pdf"
    If NomFichierValide(sNomfichier) = False Then
        Sheet1.Range("Z6").Select
        MsgBox "Invalid file name !", vbCritical + vbOKOnly
        Exit Sub
    End If

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sNomfichier, _
                                                fileFilter:="Fichiers Excel (*" & sExt1 & ", *" & sExt1)
    If oNomFichier <> False Then
        pos = InStrRev(oNomFichier, "\")
        sChemin = Left$(oNomFichier, pos - 1)
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt1)

        Erase Ar
        ReDim Ar(1) As String
        If Sheet1.Range("AG11") = 1 And Sheet1.Range("AG12") = 0 Then
            Ar(0) = Sheet1.Name
            Ar(1) = Sheet2.Name
        End If
        If Sheet1.Range("AG11") = 0 And Sheet1.Range("AG12") = 1 Then
            Ar(0) = Sheet1.Name
            Ar(1) = Sheet3.Name
        End If
        If Sheet1.Range("AG11") = 1 And Sheet1.Range("AG12") = 1 Then
            ReDim Ar(2) As String
            Ar(0) = Sheet1.Name
            Ar(1) = Sheet2.Name
            Ar(2) = Sheet3.Name
        End If
        If Sheet1.Range("AG11") = 0 And Sheet1.Range("AG12") = 0 Then
            MsgBox "Choose a type of job !", vbCritical + vbOKOnly
            Sheet1.Range("B10").Select
            Exit Sub
        End If

        ThisWorkbook.SaveCopyAs Filename:=sFichierFinal
  
        sFichierFinal = RenommerFichier(sChemin, sNomfichier & sExt2)
        Sheets(Ar).Select
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
                                        Filename:=sFichierFinal, _
                                        Quality:=xlQualityStandard, _
                                        IncludeDocProperties:=True, _
                                        IgnorePrintAreas:=False, _
                                        OpenAfterPublish:=True
        Sheet1.Select
    End If

End Sub


Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const CaracInterdits As String = """*/:<>?[\]|"

    NomFichierValide = True
    For i = 1 To Len(CaracInterdits)
        If InStr(sChaine, Mid$(CaracInterdits, i, 1)) > 0 Then
            NomFichierValide = False
            Exit Function
        End If
    Next i
End Function

Private Function RenommerFichier(sDossier As String, sNomfichier As String) As String
Dim sNouveauNom As String
Dim sPre As String, sExt As String
Dim i As Long
Dim FSO As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    If FSO.FileExists(sDossier & "\" & sNomfichier) Then
        sNouveauNom = sNomfichier
        sPre = FSO.GetBaseName(sNomfichier)
        sExt = FSO.GetExtensionName(sNomfichier)

        i = 0
        While FSO.FileExists(sDossier & "\" & sNouveauNom)
            i = i + 1
            sNouveauNom = sPre & Chr(40) & Format(i, "000") & Chr(41) & Chr(46) & sExt
        Wend
        sNomfichier = sNouveauNom
    End If
    Set FSO = Nothing

    RenommerFichier = sDossier & "\" & sNomfichier
End Function

 

[eb93]

Salut Adelme,
Comme kiki29, je ne suis pas non plus partisan du "tout cuit".
Pour ton problème, essaie de voir dans un premier temps si ton classeur est bien enregistré (je sais, c'est bête mais ça ne coute de rien de vérifier).
Si tu utilises deux fichiers Excel différents, essaie de voir si le code pointe bien vers le bon fichier.
D'une manière générale, essaie d'exécuter ton code pas-à-pas (F8), d'afficher des informations grâce à une commande Debug judicieusement placée dans ton code pour afficher une valeur dans la fenêtre d'exécution.
Bon courage

 

[Adelme]

Merci beaucoup pour ta réponse.
Ma macro fonctionne à merveille, je n'y serais pas arrivé aussi rapidement sans ce forum !