XL 2010 Modifier une macro impression pour imprimer en PDF

[SSIAP2]

bonjour à tous

je viens vous demander vos lumières pour modifier une macro d'impression que paf ma sympathiquement donner pour imprimer en pdf a la racine ou se trouve mon fichier excel

Sub ImprimeSemaine()
Dim DerL As Integer, Plage As Range, i As Integer, LD As Integer, LF As Integer
With Worksheets("Garde")
DerL = .Range("A" & Rows.Count).End(xlUp).Row
Set Plage = .Range("A4:I" & DerL)
i = 4
While i < DerL
    LD = i 'initialisation ligne de début zone
   While Weekday(.Cells(i, 1), 2) < 7 And i < DerL - 6
        If i < DerL Then i = i + 8
    Wend
    LF = i + 6 'initialisation ligne de fin zone
   i = i + 8
    With .PageSetup
    .PrintArea = "A" & LD & ":I" & LF
    .FitToPagesTall = 1 'pour avoir l'impression sur une seule feuille
   .FitToPagesWide = 1
    End With
    .PrintOut ' à remplacer par .PrintOut pour imprimer
   .PageSetup.PrintArea = ""
Wend
End With
End Sub

pouvez vous m'aider svp merci

 

[kiki29]

Salut, pour cela tu as l'enregistreur de macros qui te donnera un embryon de code à insérer ( après élagage manuel ) dans ta procédure.

 

[Lone-wolf]

Bonjour SSIAP, kiki

Renomme la feuille une par Garde et fait la mise en page et met en mode paysage avant toutes choses. Ensuite ecrit ceci après Wend > Call Imprime_Pdf, modifie le chemin du fichier si besoin.

Sub Imprime_Pdf()
Dim Fichier As String, Rep As String, Reponse

Fichier = ThisWorkbook.Path & "\Impression.xlsm"
    Reponse = MsgBox("Voulez-vous enregistrer la feuille en PDF ?", vbYesNo)
    If Reponse = vbYes Then
    Rep = Fichier & ".pdf"
        ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Rep, _
            Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
            :=False, OpenAfterPublish:=False 'n'affiche pas le fichier PDF
    Else
        Exit Sub
    End If
End Sub

 

[SSIAP2]

bonjour lone-wolf ainsi que kiki29 que je remercie pour sa macro je vais tester cela merci

 

[SSIAP2]

re bonjour à tous donc j'ai essayer de prendre tous vos conseils pour essayer arriver à mes fin le soucis c'est qu il me met bien 4 feuille de garde mais chaque fois elle est complète tous le mois au lieux etre decouper.

Sub ImprimeSemaine()
Dim DerL As Integer, Plage As Range, i As Integer, LD As Integer, LF As Integer
With Worksheets("Feuil1")
DerL = .Range("A" & Rows.Count).End(xlUp).Row
Set Plage = .Range("A3:I" & DerL)
i = 3
While i < DerL
    LD = i 'initialisation ligne de début zone
   While Weekday(.Cells(i, 1), 2) < 7 And i < DerL - 6
        If i < DerL Then i = i + 8
       
    Wend
    LF = i + 6 'initialisation ligne de fin zone
     Range("A" & LD & ":I" & LF).Select
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "E:\Planning\Projet final\Planning\PDF_Files\Feuille" & LF & ".xlsm.pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
        MsgBox LF
   i = i + 8
 
   
Wend
End With
End Sub

 

[SSIAP2]

Bon au final j'ai réussit c'est cool merci à vous

Sub ImprimeSemaine()
Dim mois As String
Dim DerL As Integer, Plage As Range, i As Integer, LD As Integer, LF As Integer
With Worksheets("Garde")
DerL = .Range("A" & Rows.Count).End(xlUp).Row
Set Plage = .Range("A4:I" & DerL)
i = 4
v = 0
While i < DerL
    LD = i 'initialisation ligne de début zone
   While Weekday(.Cells(i, 1), 2) < 7 And i < DerL - 6
        If i < DerL Then i = i + 8
       
    Wend
    LF = i + 6 'initialisation ligne de fin zone
  mois = Sheets("Dispo").Range("A2").Text & " " & v + 1
     Sheets("Garde").Range("A" & LD & ":I" & LF).Copy Sheets("PDF").Range("A3")
    
       Sheets("PDF").Select

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        "E:\Planning\Projet final\Planning\PDF_Files\FDG " & mois & ".xlsm.pdf", Quality:= _
        xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
      
        Sheets("PDF").Range("A3:I300").Delete Shift:=xlUp
    
        Sheets("garde").Select
        v = v + 1
   i = i + 8
 
Wend
End With
End Sub