Microsoft 365 Sélectionner un ou plusieurs onglets à exporter au format PDF

[pat66]

Bonjour le forum,

J'utilise cette macro pour exporter au format PDF, le problème c'est que je dois préciser les feuilles à exporter dans la macro

Est t'il possible de pouvoir choisir la ou les feuilles à exporter avant l'exécution de la macro ?

merci beaucoup

 

[Nicolas JACQUIN]

Bonjour, une idée peut-être

Public NoPrint As Boolean

Private Sub Print_PDF()

    NoPrint = True
    Application.ScreenUpdating = False

    ' Vérification nom patient
    If Sheets("Etude").Range("D22") = "Nom(s)  et  Prénom(s)" Then
        MsgBox "Vous devez préciser le nom du patient!", vbCritical, "Analyses"
        Exit Sub
    End If

    ' ===============================
    'Choix des feuilles à exporter
    ' ===============================
    Dim Choix As String
    Dim TabFeuilles() As String
    Dim i As Integer
    Dim Sh As Worksheet

    Choix = InputBox("Entrez les noms des feuilles à exporter (séparés par des virgules) :" & vbCrLf & _
                     "Exemple : Feuil1,Feuil2,Feuil3")

    If Choix = "" Then Exit Sub

    TabFeuilles = Split(Choix, ",")

    ' Nettoyage des noms
    For i = LBound(TabFeuilles) To UBound(TabFeuilles)
        TabFeuilles(i) = Trim(TabFeuilles(i))
    Next i

    ' Vérification existence feuilles
    On Error GoTo ErreurFeuille
    Sheets(TabFeuilles).Select
    On Error GoTo 0

    ' ===============================
    'Paramétrage impression
    ' ===============================
    For Each Sh In ActiveWindow.SelectedSheets

        With Sh.PageSetup
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1

            .LeftMargin = Application.InchesToPoints(0.1)
            .RightMargin = Application.InchesToPoints(0.1)
            .TopMargin = Application.InchesToPoints(1)
            .BottomMargin = Application.InchesToPoints(0.1)

            .Orientation = xlLandscape
        End With

    Next Sh

    ' ===============================
    'Nom du fichier
    ' ===============================
    Dim NFichier As String
    NFichier = Sheets(TabFeuilles(0)).Range("D20") & "-" & _
               Sheets(TabFeuilles(0)).Range("D22") & "-" & _
               Format(Date, "dd-mm-yyyy")

    ' ===============================
    'Export PDF
    ' ===============================
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\" & NFichier, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    ' Retour sur première feuille
    Sheets(TabFeuilles(0)).Select

    MsgBox "Le PDF a été enregistré !" & vbCrLf & vbCrLf & _
           "Ici ==> " & ThisWorkbook.Path & vbCrLf & vbCrLf & _
           "Sous le nom : " & NFichier & ".pdf", 64, "Analyses"

    Application.ScreenUpdating = True
    NoPrint = False
    Exit Sub

' ===============================
' Gestion erreur
' ===============================
ErreurFeuille:
    MsgBox "Une ou plusieurs feuilles n'existent pas !" & vbCrLf & _
           "Vérifiez les noms saisis.", vbCritical
    Application.ScreenUpdating = True
    NoPrint = False

End Sub

Nicolas

 

[pat66]

Bonjour

et merci pour votre aide

J'ai suivi vos instructions, mais la macro bloque sur :
On Error GoTo ErreurFeuille
Sheets(TabFeuilles).Select
On Error GoTo 0

et pourtant j'ai bien saisi dans l'inputbox : Feuil1

merci encore

 

[Nicolas JACQUIN]

Excel cherche une feuille qui s’appelle exactement “Feuil1” (nom d’onglet)

A tester par ce code:

Dim ListeFeuilles As Collection
Set ListeFeuilles = New Collection

Dim NomF As String
Dim Trouve As Boolean

For i = LBound(TabFeuilles) To UBound(TabFeuilles)

    NomF = TabFeuilles(i)
    Trouve = False

    ' Recherche par nom d'onglet
    For Each Sh In ThisWorkbook.Worksheets
        If LCase(Sh.Name) = LCase(NomF) Then
            ListeFeuilles.Add Sh.Name
            Trouve = True
            Exit For
        End If
    Next Sh

    ' Recherche par CodeName
    If Not Trouve Then
        For Each Sh In ThisWorkbook.Worksheets
            If LCase(Sh.CodeName) = LCase(NomF) Then
                ListeFeuilles.Add Sh.Name
                Trouve = True
                Exit For
            End If
        Next Sh
    End If

    If Not Trouve Then
        MsgBox "Feuille introuvable : " & NomF, vbCritical
        Exit Sub
    End If

Next i

' Conversion collection → tableau
Dim TabSelect() As String
ReDim TabSelect(0 To ListeFeuilles.Count - 1)

For i = 1 To ListeFeuilles.Count
    TabSelect(i - 1) = ListeFeuilles(i)
Next i

Sheets(TabSelect).Select

 

[TooFatBoy]

Hi,

Private Sub Worksheet_Activate()
    ActiveSheet.ListBox1.Clear
    For Each Feuille In ThisWorkbook.Sheets
        If Feuille.PageSetup.PrintArea <> "" Then ActiveSheet.ListBox1.AddItem Feuille.Name
    Next
End Sub

cf PJ.

 

[pat66]

Excel cherche une feuille qui s’appelle exactement “Feuil1” (nom d’onglet)

A tester par ce code:

Dim ListeFeuilles As Collection
Set ListeFeuilles = New Collection

Dim NomF As String
Dim Trouve As Boolean

For i = LBound(TabFeuilles) To UBound(TabFeuilles)

    NomF = TabFeuilles(i)
    Trouve = False

    ' Recherche par nom d'onglet
    For Each Sh In ThisWorkbook.Worksheets
        If LCase(Sh.Name) = LCase(NomF) Then
            ListeFeuilles.Add Sh.Name
            Trouve = True
            Exit For
        End If
    Next Sh

    ' Recherche par CodeName
    If Not Trouve Then
        For Each Sh In ThisWorkbook.Worksheets
            If LCase(Sh.CodeName) = LCase(NomF) Then
                ListeFeuilles.Add Sh.Name
                Trouve = True
                Exit For
            End If
        Next Sh
    End If

    If Not Trouve Then
        MsgBox "Feuille introuvable : " & NomF, vbCritical
        Exit Sub
    End If

Next i

' Conversion collection → tableau
Dim TabSelect() As String
ReDim TabSelect(0 To ListeFeuilles.Count - 1)

For i = 1 To ListeFeuilles.Count
    TabSelect(i - 1) = ListeFeuilles(i)
Next i

Sheets(TabSelect).Select

REe,
effectivement il fallait que je précise le ou les noms d'onglets

Bonjour, une idée peut-être

Public NoPrint As Boolean

Private Sub Print_PDF()

    NoPrint = True
    Application.ScreenUpdating = False

    ' Vérification nom patient
    If Sheets("Etude").Range("D22") = "Nom(s)  et  Prénom(s)" Then
        MsgBox "Vous devez préciser le nom du patient!", vbCritical, "Analyses"
        Exit Sub
    End If

    ' ===============================
    'Choix des feuilles à exporter
    ' ===============================
    Dim Choix As String
    Dim TabFeuilles() As String
    Dim i As Integer
    Dim Sh As Worksheet

    Choix = InputBox("Entrez les noms des feuilles à exporter (séparés par des virgules) :" & vbCrLf & _
                     "Exemple : Feuil1,Feuil2,Feuil3")

    If Choix = "" Then Exit Sub

    TabFeuilles = Split(Choix, ",")

    ' Nettoyage des noms
    For i = LBound(TabFeuilles) To UBound(TabFeuilles)
        TabFeuilles(i) = Trim(TabFeuilles(i))
    Next i

    ' Vérification existence feuilles
    On Error GoTo ErreurFeuille
    Sheets(TabFeuilles).Select
    On Error GoTo 0

    ' ===============================
    'Paramétrage impression
    ' ===============================
    For Each Sh In ActiveWindow.SelectedSheets

        With Sh.PageSetup
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1

            .LeftMargin = Application.InchesToPoints(0.1)
            .RightMargin = Application.InchesToPoints(0.1)
            .TopMargin = Application.InchesToPoints(1)
            .BottomMargin = Application.InchesToPoints(0.1)

            .Orientation = xlLandscape
        End With

    Next Sh

    ' ===============================
    'Nom du fichier
    ' ===============================
    Dim NFichier As String
    NFichier = Sheets(TabFeuilles(0)).Range("D20") & "-" & _
               Sheets(TabFeuilles(0)).Range("D22") & "-" & _
               Format(Date, "dd-mm-yyyy")

    ' ===============================
    'Export PDF
    ' ===============================
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=ThisWorkbook.Path & "\" & NFichier, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=True

    ' Retour sur première feuille
    Sheets(TabFeuilles(0)).Select

    MsgBox "Le PDF a été enregistré !" & vbCrLf & vbCrLf & _
           "Ici ==> " & ThisWorkbook.Path & vbCrLf & vbCrLf & _
           "Sous le nom : " & NFichier & ".pdf", 64, "Analyses"

    Application.ScreenUpdating = True
    NoPrint = False
    Exit Sub

' ===============================
' Gestion erreur
' ===============================
ErreurFeuille:
    MsgBox "Une ou plusieurs feuilles n'existent pas !" & vbCrLf & _
           "Vérifiez les noms saisis.", vbCritical
    Application.ScreenUpdating = True
    NoPrint = False

End Sub

Nicolas

Re,

effectivement je n'avais pas saisit le nom de l'onglet, maintenant la macro fonctionne parfaitement et je vous en remercie
Maintenant je vais essayer de l'adapter à celle de mon classeur post# 1 avec notamment la prise en compte des zones à imprimer car
elles sont différentes

Concernant le post "#4, je ne sais comment l'utiliser, mais merci quand même

merci beaucoup

 

[fanch55]

Si cela peut aider :

XL 2016 Publié dans la discussion 'Bouton pour Impression de plusieurs fuilles excel dans le même fichier pdf par exempe'

8 Mai 2020

Bonjour,
Comme promis sur l'autre fil, je vous donne la solution.
Je partage l'avis de @kiki29 ( bien que son code s'adresse déjà à des personnes avancées dans les macros), vous auriez pu trouver tout seul :

Voici donc un code "tout cuit" à placer sur la feuille ou se trouve votre bouton imprimante:

Option Explicit
Private Sub CommandButton2_Click()
Dim PrintDlg        As DialogSheet
Dim CurrentSheet    As Worksheet
Dim Sh              As Worksheet
Dim Cb              As CheckBox
Dim Sel_Sheets      As String
Dim FileName        As Variant
Dim TopPos          As Integer...

• fanch55