XL 2010 VBA - Format d'impression du PDF identique aux fichiers Excel

tchi456 · 13 Septembre 2021

Bonjour,

J'ai un code VBA qui fonctionne bien cependant je n'arrive pas à avoir les bons paramètres d'impression (orientation, marges, positionnement, etc..).

En effet lorsque je clique sur le bouton imprimer du fichier "Impression du rapport d'inspection en PDF", j'aimerai que les paramètres d'impression de mon pdf soient identiques aux paramètres d'impression des mes 3 autres fichiers excel (le pdf devrait comporter 6 feuilles avec une orientation paysage au lieu des 19).

Est-ce que c'est réalisable?

Mes meilleures salutations,

Thierry

fanch55 · 16 Septembre 2021

Rapport Final ==> impression de masse
Rapport Pdf ==> impression unitaire
J'avais fait en sorte que l'exploitant ne prenne pas l'habitude de toujours utiliser le même bouton ( économie de feuilles )

Mais si vous voulez tout faire avec un seul bouton :

VB:

Option Explicit
Option Compare Text
 
Sub Imprimer()
    Dim Sh As Worksheet, Proceed As Boolean, ShToExport, Elem
    Dim Fichier_traité As String, Chemin As String, Psw As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ThisWorkbook.Save ' On va rajouter des onglets fantômes alors on sauvegarde avant
        
    Psw = "."
    Chemin = ThisWorkbook.Path & "\"
    Fichier_traité = Dir(Chemin &...

fanch55 · 14 Septembre 2021

Bonjour,
Code à mettre avant l'export :

VB:

    With ActiveSheet.PageSetup
        .PrintArea = ""
        Application.PrintCommunication = False
        .CenterHorizontally = True
        .Orientation = xlLandscape
        .FitToPagesWide = 1
        .FitToPagesTall = False
        Application.PrintCommunication = True
    End With

Vous aurez 7 pages au lieu des 19 initiales et des 6 prévues.
Mais cela est dû à la conception des copies de pages .
Les cellules des pages de résumés auront leur largeur dépendante des pages d'inspection ...

tchi456 · 15 Septembre 2021

Bonjour,

Merci beaucoup pour votre aide.
Ca fonctionne déjà mieux mais l'affichage reste quand même bien différent de la feuille d'origine.

Mes meilleures salutations,

Thierry

fanch55 · 15 Septembre 2021

Re-Bonjour,
Le code ci-dessous devrait répondre à votre demande :

VB:

Option Explicit
Sub Imprimer()
    Dim Sh As Worksheet, Proceed As Boolean
    Dim Fichier_traité As String, Chemin As String, DerLig As Integer
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
        
    Chemin = ThisWorkbook.Path & "\"
    Fichier_traité = Dir(Chemin & "*.xls*")
    Do While Fichier_traité <> ""
        If Fichier_traité <> ThisWorkbook.Name Then
            Proceed = True
            With Workbooks.Open(Chemin & Fichier_traité)
                .Worksheets(Array("Inspection machine", "Résumé")).Copy _
                    After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                .Close False
            End With
        End If
        Fichier_traité = Dir
    Loop
    
    If Proceed Then
        For Each Sh In ThisWorkbook.Worksheets
            If Sh.Name <> "Impression" Then Sh.Select Replace:=False
        Next
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Chemin & Format(Date, "YYYYMMDD") & " - " & "Rapport d'inspection.pdf", _
            OpenAfterPublish:=True
        ActiveWindow.SelectedSheets.Delete
        ThisWorkbook.Saved = True ' Pour ne pas sauvegarder
    End If
    
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
End Sub

tchi456 · 15 Septembre 2021

Bonjour,

Ce code fonctionne à merveille sur un fichier Excel séparé. Merci infiniment.
Par contre si je souhaite intégrer ce bouton "Rapport final" dans chaque fichier Excel qui comporte les feuilles en question ça ne fonctionne malheureusement pas.

Mes meilleures salutations,

Thierry

fanch55 · 15 Septembre 2021

tchi456 à dit:
Ce code fonctionne à merveille sur un fichier Excel séparé. Merci infiniment.
Par contre si je souhaite intégrer ce bouton "Rapport final" dans chaque fichier Excel qui comporte les feuilles en question ça ne fonctionne malheureusement pas.

Le code proposé était adapté au contexte de la demande initiale

Celui ci-dessous peut être intégré dans chacun des fichiers Inspection comme vous le demandez par la suite:

VB:

Option Explicit
Option Compare Text
 
Sub Imprimer()
    Dim Sh As Worksheet, Proceed As Boolean, ShToExport, Elem
    Dim Fichier_traité As String, Chemin As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ThisWorkbook.Save ' On va rajouter des onglets fantômes alors on sauvegarde avant
        
    Chemin = ThisWorkbook.Path & "\"
    Fichier_traité = Dir(Chemin & "*.xls*")
    ShToExport = Array("Inspection machine", "Résumé")
    
    Do While Fichier_traité <> ""
        If Fichier_traité <> ThisWorkbook.Name Then
            Proceed = True
            With Workbooks.Open(Chemin & Fichier_traité)
                ' le Titre est une formule vers le nom de fichier initial : on ne conserve que le Texte
                .Worksheets("Inspection machine").[A1] = .Worksheets("Inspection machine").[A1].Value
                .Worksheets(ShToExport).Copy _
                    After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                .Close False
            End With
        Else
            ThisWorkbook.Worksheets(ShToExport).Copy _
                After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        End If
        Fichier_traité = Dir
    Loop
    
    If Proceed Then
        For Each Sh In ThisWorkbook.Worksheets
            For Each Elem In ShToExport
                If InStr(1, Sh.Name, Elem & " (", vbTextCompare) Then
                    Sh.Select Replace:=False
                    Exit For
                End If
            Next
        Next
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Chemin & Format(Date, "YYYYMMDD") & " - " & "Rapport d'inspection.pdf", _
            OpenAfterPublish:=True
         ActiveWindow.SelectedSheets.Delete
         Worksheets(ShToExport(0)).Activate
    End If
    
    ThisWorkbook.Saved = True ' La situation devrait être celle de la sauvegarde en début de sub
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
End Sub

tchi456 · 15 Septembre 2021

Re bonjour,

Votre code fonctionne très bien jusqu'à ce que je verrouille les feuilles (le mot de passe est un point ".")

fanch55 · 15 Septembre 2021

code modifié,
mais vous pourriez donner dès le début toutes les contraintes
ou corriger par vous même, ce n'est pas sorcier un unprotect ...

Code:

Option Explicit
Option Compare Text
 
Sub Imprimer()
    Dim Sh As Worksheet, Proceed As Boolean, ShToExport, Elem
    Dim Fichier_traité As String, Chemin As String, Psw As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ThisWorkbook.Save ' On va rajouter des onglets fantômes alors on sauvegarde avant
        
    Psw = "."
    Chemin = ThisWorkbook.Path & "\"
    Fichier_traité = Dir(Chemin & "*.xls*")
    ShToExport = Array("Inspection machine", "Résumé")
    
    Do While Fichier_traité <> ""
        If Fichier_traité <> ThisWorkbook.Name Then
            Proceed = True
            With Workbooks.Open(Chemin & Fichier_traité)
                ' le Titre est une formule vers le nom de fichier initial : on ne conserve que le Texte
                With .Worksheets("Inspection machine")
                    .UnProtect Psw
                    .[A1] = .[A1].Value
                End With
                .Worksheets(ShToExport).Copy _
                    After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                .Close False
            End With
        Else
            ThisWorkbook.Worksheets(ShToExport).Copy _
                After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        End If
        Fichier_traité = Dir
    Loop
    
    If Proceed Then
        For Each Sh In ThisWorkbook.Worksheets
            For Each Elem In ShToExport
                If InStr(1, Sh.Name, Elem & " (", vbTextCompare) Then
                    Sh.Select Replace:=False
                    Exit For
                End If
            Next
        Next
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Chemin & Format(Date, "YYYYMMDD") & " - " & "Rapport d'inspection.pdf", _
            OpenAfterPublish:=True
         ActiveWindow.SelectedSheets.Delete
         Worksheets(ShToExport(0)).Activate
    End If
    
    ThisWorkbook.Saved = True ' La situation devrait être celle de la sauvegarde en début de sub
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
End Sub

tchi456 · 16 Septembre 2021

Bonjour,

J'ai fait le test avec plusieurs fichiers et ça fonctionne très bien par contre ça ne fonctionne pas si j'en ai qu'un seul.

Peut-on faire en sorte que le code soit fonctionnel peut importe le nombre de fichiers Excel ?

Mes meilleures salutations,

Thierry

fanch55 · 16 Septembre 2021

Rapport Final ==> impression de masse
Rapport Pdf ==> impression unitaire
J'avais fait en sorte que l'exploitant ne prenne pas l'habitude de toujours utiliser le même bouton ( économie de feuilles )

Mais si vous voulez tout faire avec un seul bouton :

VB:

Option Explicit
Option Compare Text
 
Sub Imprimer()
    Dim Sh As Worksheet, Proceed As Boolean, ShToExport, Elem
    Dim Fichier_traité As String, Chemin As String, Psw As String
    
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    
    ThisWorkbook.Save ' On va rajouter des onglets fantômes alors on sauvegarde avant
        
    Psw = "."
    Chemin = ThisWorkbook.Path & "\"
    Fichier_traité = Dir(Chemin & "*.xls*")
    ShToExport = Array("Inspection machine", "Résumé")
    
    Do While Fichier_traité <> ""
        If Fichier_traité <> ThisWorkbook.Name Then
            With Workbooks.Open(Chemin & Fichier_traité)
                ' le Titre est une formule vers le nom de fichier initial : on ne conserve que le Texte
                With .Worksheets("Inspection machine")
                    .UnProtect Psw
                    .[A1] = .[A1].Value
                End With
                .Worksheets(ShToExport).Copy _
                    After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
                .Close False
            End With
        Else
            ThisWorkbook.Worksheets(ShToExport).Copy _
                After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        End If
        Proceed = True
        Fichier_traité = Dir
    Loop
    
    If Proceed Then
        For Each Sh In ThisWorkbook.Worksheets
            For Each Elem In ShToExport
                If InStr(1, Sh.Name, Elem & " (", vbTextCompare) Then
                    Sh.Select Replace:=False
                    Exit For
                End If
            Next
        Next
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _
            Filename:=Chemin & Format(Date, "YYYYMMDD") & " - " & "Rapport d'inspection.pdf", _
            OpenAfterPublish:=True
         ActiveWindow.SelectedSheets.Delete
         Worksheets(ShToExport(0)).Activate
    End If
    
    ThisWorkbook.Saved = True ' La situation devrait être celle de la sauvegarde en début de sub
    Application.DisplayAlerts = True
    Application.EnableEvents = True
    
End Sub

tchi456 · 16 Septembre 2021

Qu'est-ce que j'aimerai être à votre niveau. Vous êtes une bête !

J'estime être un bon utilisateur Excel avec ses formules et ses fonctions mais pour ce qui du VBA j'avoue que c'est pour moi du chinois.

Merci infiniment !

Je vous adresse mes respectueuses salutations et vous souhaite une bonne fin de semaine.

Thierry

XL 2010 VBA - Format d'impression du PDF identique aux fichiers Excel

tchi456

XLDnaute Occasionnel

Pièces jointes

fanch55

fanch55

XLDnaute Barbatruc

tchi456

XLDnaute Occasionnel

Pièces jointes

fanch55

XLDnaute Barbatruc

tchi456

XLDnaute Occasionnel

Pièces jointes

fanch55

XLDnaute Barbatruc

tchi456

XLDnaute Occasionnel

Pièces jointes

fanch55

XLDnaute Barbatruc

tchi456

XLDnaute Occasionnel

Pièces jointes

fanch55

XLDnaute Barbatruc

tchi456

XLDnaute Occasionnel

Discussions similaires