XL 2016 enregistrer une zone d'impression en pdf

Linda42

XLDnaute Occasionnel
Bonjour,

J'ai besoin de votre aide pour pouvoir enregistrer une parti de ma feuille en PDF ou excel (le choix sera fait par l'utilisateur final).

Je suis partie avec l'idée de définir la zone d'impression souhaitée et l'enregistrer en pdf ou excel.

J'aimerais rajouter un message lorsqu'on cliquera sur le bouton "Vous préconisez l’adhésion à un groupement de commande ou à une centrale d’achats et avez fini de saisir votre fiche stratégie. Souhaitez vous enregistrer votre fichier sous pdf ou excel?

Et en fonction du choix, je souhaiterais que le chemin et le nom du fichier soit pré-défini :
Zone d'impression ou d'enregistrement A1:U104
Dans le fichier C\Users\mes documents (attention ce fichier est destiné à être utilisé par plusieurs utilisateurs - c'est donc dans leur document respectif que je voudrais que cela s'enregistre) une fois arrivé à cette étape, ils seront libres de choisir des dossiers/sous dossiers)
Avec un nom de fichier "Fiche Stratégie - " & .range("I110") & .range("I11") et je présume & ".pdf" ou excel

Meri pour votre aide.
Linda
 
Solution
Re, la seule ligne suffit
VB:
 Feuil1.PageSetup.PrintArea = "$A$1:$U$101"
Feuil1 étant le CodeName de l'onglet concerné.

Une version avec Test des noms de fichiers ainsi que gestion des doublons éventuels via un indice.
VB:
Option Explicit

Sub EnregistrerSous_05()
Dim sNomFichier As String, sDossier As String
Dim oNomFichier As Variant,  sNomFinal As String
Dim bDoublon As Boolean

    bDoublon = True
    ' bDoublon = False
    sDossier = Environ("USERPROFILE") & "\" & "Documents"
    'sDossier = ThisWorkbook.Path

    sNomFichier = "Fiche Stratégie - " & Feuil1.Cells(10, 9) & " " & Feuil1.Cells(11, 9) & ".pdf"
    If NomFichierValide(sNomFichier) = False Then
        MsgBox "Attention : Nom de fichier invalide", vbOKOnly...

kiki29

XLDnaute Barbatruc
Re, sauve la feuille Excel en PDF à toi de poursuivre.
VB:
Sub EnregistrerSous_03()
Dim sNomFichier As String, sDossier As String
Dim oNomFichier As Variant

    sDossier = Environ("USERPROFILE") & "\" & "Documents"
    'sDossier = ThisWorkbook.Path

    sNomFichier = "Fiche Stratégie - " & Feuil1.Cells(10, 9) & " " & Feuil1.Cells(11, 9)

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sDossier & "\" & sNomFichier, _
                                                fileFilter:="Fichiers PDF (*.pdf),*.pdf")
    If oNomFichier <> False Then
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=oNomFichier, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=False
    End If
End Sub
 
Dernière édition:

Linda42

XLDnaute Occasionnel
Re, sauve la feuille Excel en PDF à toi de poursuivre.
VB:
Sub EnregistrerSous_03()
Dim sNomFichier As String, sDossier As String
Dim oNomFichier As Variant

    sDossier = Environ("USERPROFILE") & "\" & "Documents"
    'sDossier = ThisWorkbook.Path

    sNomFichier = "Fiche Stratégie - " & Feuil1.Cells(10, 9) & " " & Feuil1.Cells(11, 9)

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sDossier & "\" & sNomFichier, _
                                                fileFilter:="Fichiers PDF (*.pdf),*.pdf")
    If oNomFichier <> False Then
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=oNomFichier, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=False
    End If
End Sub
Merci beaucoup pour cette aide précieuse, j'ai rajouté la zone d'impression avant, défini la nouvelle zone d'impression après. Ça fonctionne :)

VB:
Sub ExpotPDF_Si_CA_GDC()
Dim sNomFichier As String, sDossier As String
Dim oNomFichier As Variant

    sDossier = Environ("USERPROFILE") & "\" & "Documents"
    'sDossier = ThisWorkbook.Path

    sNomFichier = "Fiche Stratégie - " & Feuil1.Cells(10, 9) & " " & Feuil1.Cells(11, 9)

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sDossier & "\" & sNomFichier, _
                                                fileFilter:="Fichiers PDF (*.pdf),*.pdf")
    Range("A1:U101").Select
    Range("U101").Activate
    ActiveSheet.PageSetup.PrintArea = "$A$1:$U$101"
    
    If oNomFichier <> False Then
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=oNomFichier, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=False
    End If
    Range("A1:U334").Select
    ActiveSheet.PageSetup.PrintArea = "$A$1:$U$334"
End Sub
 

kiki29

XLDnaute Barbatruc
Re, la seule ligne suffit
VB:
 Feuil1.PageSetup.PrintArea = "$A$1:$U$101"
Feuil1 étant le CodeName de l'onglet concerné.

Une version avec Test des noms de fichiers ainsi que gestion des doublons éventuels via un indice.
VB:
Option Explicit

Sub EnregistrerSous_05()
Dim sNomFichier As String, sDossier As String
Dim oNomFichier As Variant,  sNomFinal As String
Dim bDoublon As Boolean

    bDoublon = True
    ' bDoublon = False
    sDossier = Environ("USERPROFILE") & "\" & "Documents"
    'sDossier = ThisWorkbook.Path

    sNomFichier = "Fiche Stratégie - " & Feuil1.Cells(10, 9) & " " & Feuil1.Cells(11, 9) & ".pdf"
    If NomFichierValide(sNomFichier) = False Then
        MsgBox "Attention : Nom de fichier invalide", vbOKOnly + vbCritical
        Exit Sub
    End If

    Feuil1.PageSetup.PrintArea = "$A$1:$U$101"

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sDossier & "\" & sNomFichier, _
                                                fileFilter:="Fichiers PDF (*.pdf),*.pdf")
    If oNomFichier <> False Then
        sNomFinal = oNomFichier
        If bDoublon Then sNomFinal = RenommerFichier(sDossier, sNomFichier)
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=sNomFinal, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=False
    End If
End Sub

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?\|[]"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, 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 Dir(sDossier & "\" & sNomFichier, vbNormal) <> vbNullString Then
        sNouveauNom = sNomFichier
        sPre = Fso.GetBaseName(sNomFichier)
        sExt = Fso.GetExtensionName(sNomFichier)

        i = 0
        While Dir(sDossier & "\" & sNouveauNom, vbNormal) <> vbNullString
            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
 

Pièces jointes

  • CodeName.png
    CodeName.png
    74.9 KB · Affichages: 26
  • 3.png
    3.png
    20.3 KB · Affichages: 27
Dernière édition:

Linda42

XLDnaute Occasionnel
Re, la seule ligne suffit
VB:
 Feuil1.PageSetup.PrintArea = "$A$1:$U$101"
Feuil1 étant le CodeName de l'onglet concerné.

Une version avec Test des noms de fichiers ainsi que gestion des doublons éventuels via un indice.
VB:
Option Explicit

Sub EnregistrerSous_05()
Dim sNomFichier As String, sDossier As String
Dim oNomFichier As Variant,  sNomFinal As String
Dim bDoublon As Boolean

    bDoublon = True
    ' bDoublon = False
    sDossier = Environ("USERPROFILE") & "\" & "Documents"
    'sDossier = ThisWorkbook.Path

    sNomFichier = "Fiche Stratégie - " & Feuil1.Cells(10, 9) & " " & Feuil1.Cells(11, 9) & ".pdf"
    If NomFichierValide(sNomFichier) = False Then
        MsgBox "Attention : Nom de fichier invalide", vbOKOnly + vbCritical
        Exit Sub
    End If

    Feuil1.PageSetup.PrintArea = "$A$1:$U$101"

    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sDossier & "\" & sNomFichier, _
                                                fileFilter:="Fichiers PDF (*.pdf),*.pdf")
    If oNomFichier <> False Then
        sNomFinal = oNomFichier
        If bDoublon Then sNomFinal = RenommerFichier(sDossier, sNomFichier)
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=sNomFinal, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=False
    End If
End Sub

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?\|[]"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, 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 Dir(sDossier & "\" & sNomFichier, vbNormal) <> vbNullString Then
        sNouveauNom = sNomFichier
        sPre = Fso.GetBaseName(sNomFichier)
        sExt = Fso.GetExtensionName(sNomFichier)

        i = 0
        While Dir(sDossier & "\" & sNouveauNom, vbNormal) <> vbNullString
            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
Super,
j'ai utilisé ce code et cela fonctionne bien.


J'ai donc voulu le réutiliser sur une autre feuille du même fichier avec le code suivant :

VB:
Option Explicit

Sub EnregistrerSous_Annexe1_PDF()
Dim sNomFichier As String, sDossier As String
Dim oNomFichier As Variant, sNomFinal As String
Dim bDoublon As Boolean

    bDoublon = True
    ' bDoublon = False
    sDossier = Environ("USERPROFILE") & "\" & "Documents"
    'sDossier = ThisWorkbook.Path

    sNomFichier = "Fiche Stratégie - " & Feuil1.Cells(10, 9) & " " & Feuil1.Cells(11, 9) & "  - Annexe 1" & ".pdf"
    If NomFichierValide(sNomFichier) = False Then
        MsgBox "Attention : Nom de fichier invalide", vbOKOnly + vbCritical
        Exit Sub
    End If


    oNomFichier = Application.GetSaveAsFilename(InitialFileName:=sDossier & "\" & sNomFichier, _
                                                fileFilter:="Fichiers PDF (*.pdf),*.pdf")
    If oNomFichier <> False Then
        sNomFinal = oNomFichier
        If bDoublon Then sNomFinal = RenommerFichier(sDossier, sNomFichier)
        Feuil1.ExportAsFixedFormat Type:=xlTypePDF, _
                                   Filename:=sNomFinal, _
                                   Quality:=xlQualityStandard, _
                                   IncludeDocProperties:=True, _
                                   IgnorePrintAreas:=False, _
                                   OpenAfterPublish:=False
    End If
    Range("A1").Select
End Sub

Private Function NomFichierValide(sChaine As String) As Boolean
Dim i As Long
Const sCaracInterdits As String = """*/:<>?\|[]"
    NomFichierValide = True
    If Len(sChaine) = 0 Then
        NomFichierValide = False
        Exit Function
    End If
    For i = 1 To Len(sCaracInterdits)
        If InStr(sChaine, Mid$(sCaracInterdits, 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 Dir(sDossier & "\" & sNomFichier, vbNormal) <> vbNullString Then
        sNouveauNom = sNomFichier
        sPre = Fso.GetBaseName(sNomFichier)
        sExt = Fso.GetExtensionName(sNomFichier)

        i = 0
        While Dir(sDossier & "\" & sNouveauNom, vbNormal) <> vbNullString
            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


Il fonctionne mais l'export qui est fait est celui de la fiche stratégie et pas de la feuille souhaitée. J'ai tenté de trouver dans ton code la notion de active.sheet mais je coince.

Cdt
 

Discussions similaires

Statistiques des forums

Discussions
311 732
Messages
2 081 995
Membres
101 857
dernier inscrit
mt60400