Option Explicit
Sub mep()
Dim dl As Long, col As Byte, HPage As Integer, VPage As Byte, x As Integer
ActiveWindow.View = xlPageBreakPreview
With ActiveSheet
dl = .UsedRange.Rows.Count
.ResetAllPageBreaks
.PageSetup.PrintArea = "A1:k" & dl
.PageSetup.PrintTitleRows = "$1:$4"
HPage = .HPageBreaks.Count
VPage = .VPageBreaks.Count
If VPage >= 1 Then .VPageBreaks(1).DragOff Direction:=xlToRight, RegionIndex:=1
If HPage >= 1 Then
For x = dl To 1 Step -1
If .Cells(x, 9).Borders(xlEdgeTop).LineStyle = xlContinuous Then
.HPageBreaks.Add Before:=Range("A" & x - 1)
Exit For
End If
Next x
End If
End With
ActiveWindow.View = xlNormalView
End Sub
Sub test()
With ActiveSheet
'dl = .UsedRange.Rows.Count 'Attention c'est pas bon si le usedrange ne commence pas en ligne 1
dl = .UsedRange.Cells(.UsedRange.Cells.Count).Row 'Là on est sur!!!!
.PageSetup.PrintArea = "A6:E" & dl
'
'ton arrangement ici
'
nbpages = (.HPageBreaks.Count + 1) * (.VPageBreaks.Count + 1)
'impression des pages (count-1)
.PageSetup.PrintTitleRows = "$1:$4"
ActiveSheet.PrintOut from:=1, To:=nbpages - 1 'On imprime tout jusqu'à l'avant dernière page
'impression de la derniere page
.PageSetup.PrintTitleRows = "" 'on enlève les entêtes
ActiveSheet.PrintOut from:=nbpages, To:=nbpages 'On imprime la dernière page
End With
End Sub
Merci beaucoup Patrick,re
c'est un piège bien connu le usedrange
malheureusement si tu veux persister a utiliser save Ad tu va devoir composer creer x feuille ou une seul avec le report 1:4 a chaque fois
avec bullzip et l'option coché tu n'aurais plus a faire quoi que ce soit
d'autant plus que ca pourrait te servir pour imprimer en pdf une page web ou toute autre fenêtre imprimable
et tu garderais uniquement ce code
VB:Sub test() With ActiveSheet 'dl = .UsedRange.Rows.Count 'Attention c'est pas bon si le usedrange ne commence pas en ligne 1 dl = .UsedRange.Cells(.UsedRange.Cells.Count).Row 'Là on est sur!!!! .PageSetup.PrintArea = "A6:E" & dl ' 'ton arrangement ici ' nbpages = (.HPageBreaks.Count + 1) * (.VPageBreaks.Count + 1) 'impression des pages (count-1) .PageSetup.PrintTitleRows = "$1:$4" ActiveSheet.PrintOut from:=1, To:=nbpages - 1 'On imprime tout jusqu'à l'avant dernière page 'impression de la derniere page .PageSetup.PrintTitleRows = "" 'on enlève les entêtes ActiveSheet.PrintOut from:=nbpages, To:=nbpages 'On imprime la dernière page End With End Sub
Bonjour Patrickre
bonjour @cathodique
j'ai finalisé la solution sans ajout de feuille
si ça t’intéresse fait moi le savoir
Option Explicit
Sub testx()
Dim dl&, dl2&, dl3&, i&, a&, c As Range, nbpages&, tbsheet(), sh, debut, rg As Range, entete As Range, col1$, col2$, chemin$
Application.DisplayAlerts = False
debut = 5 'ici la ligne du debut à imprimer
With Feuil1
dl = .UsedRange.Cells(.UsedRange.Cells.Count).Row 'Là on est sur!!!!
dl2 = dl + 5 'on collera les tableaux(pages copiées) à partir de cette ligne
dl3 = dl2 'pour garder en memoire la premiere ligne de ce qui sera vraiment imprimé
'-------------------------------------------------------------
Set entete = .[A1:K4] 'determine l'entete
col1 = "A" 'premiere colonne du tableau en lettre
col2 = "K" 'derniere colonne du tableau en lettre
chemin = ThisWorkbook.Path & "\" & "Test.pdf"
'-------------------------------------------------------------
For i = 5 To dl 'redim preserve dans un array des plagesséparées par un saut de ligne
If .Rows(i).PageBreak <> xlNone Then
If i - 1 > debut Then
a = a + 1
ReDim Preserve tbsheet(1 To a): tbsheet(a) = .Range(col1 & debut & ":" & col2 & i - 1).Address(0, 0)
debut = i
End If
End If
Next
a = a + 1: ReDim Preserve tbsheet(1 To a): tbsheet(a) = .Range(col1 & debut & ":" & col2 & dl).Address(0, 0)
MsgBox "juste pour voir " & vbCrLf & Join(tbsheet, vbCrLf) ' à supprimer
'controle des sauts de page résiduel en dessous du tableau original
nbpages = (.HPageBreaks.Count + 1) * (.VPageBreaks.Count + 1)
For i = a + 1 To nbpages
On Error Resume Next
ActiveSheet.HPageBreaks(i).Delete
Next
'reconstruction des tableaux avec entete en dessous de l'original
For i = LBound(tbsheet) To UBound(tbsheet)
If i < UBound(tbsheet) Then Set c = Union(entete, .Range(tbsheet(i))) Else Set c = .Range(tbsheet(i))
c.Copy .Range(col1 & dl2)
dl2 = .UsedRange.Cells(.UsedRange.Cells.Count).Row 'Là on est sur!!!!
If i < UBound(tbsheet) Then ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=.UsedRange.Cells(.UsedRange.Cells.Count)
Next
'si on veut simplement imprimer
'on imprime les pages reconstruite
'.Range(.Range("A" & dl3), .UsedRange.Cells(.UsedRange.Cells.Count)).PrintPreview 'ou printout sur ton imprimante pdf
Set rg = .Range(.Range(col1 & dl3), .UsedRange.Cells(.UsedRange.Cells.Count)) 'ça c'est la plage des tableaux reconstruits
'export pdf
rg.ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
Set rg = Nothing
'et enfin on supprime les pages reconstruites pour revenir à l'original
.Range(.Range(col1 & dl3), Range(col2 & Rows.Count)).EntireRow.Delete Shift:=xlUp
End With
End Sub
Bonjour PatrickToulonre
et pour que tu puisse te l'adapter plus facilement je variabilise les choses qui changent pendant l’exécution entre les deux lignes pointillées
là pour le coup je peux pas faire mieuxVB:Option Explicit Sub testx() Dim dl&, dl2&, dl3&, i&, a&, c As Range, nbpages&, tbsheet(), sh, debut, rg As Range, entete As Range, col1$, col2$, chemin$ Application.DisplayAlerts = False debut = 5 'ici la ligne du debut à imprimer With Feuil1 dl = .UsedRange.Cells(.UsedRange.Cells.Count).Row 'Là on est sur!!!! dl2 = dl + 5 'on collera les tableaux(pages copiées) à partir de cette ligne dl3 = dl2 'pour garder en memoire la premiere ligne de ce qui sera vraiment imprimé '------------------------------------------------------------- Set entete = .[A1:K4] 'determine l'entete col1 = "A" 'premiere colonne du tableau en lettre col2 = "K" 'derniere colonne du tableau en lettre chemin = ThisWorkbook.Path & "\" & "Test.pdf" '------------------------------------------------------------- For i = 5 To dl 'redim preserve dans un array des plagesséparées par un saut de ligne If .Rows(i).PageBreak <> xlNone Then If i - 1 > debut Then a = a + 1 ReDim Preserve tbsheet(1 To a): tbsheet(a) = .Range(col1 & debut & ":" & col2 & i - 1).Address(0, 0) debut = i End If End If Next a = a + 1: ReDim Preserve tbsheet(1 To a): tbsheet(a) = .Range(col1 & debut & ":" & col2 & dl).Address(0, 0) MsgBox "juste pour voir " & vbCrLf & Join(tbsheet, vbCrLf) ' à supprimer 'controle des sauts de page résiduel en dessous du tableau original nbpages = (.HPageBreaks.Count + 1) * (.VPageBreaks.Count + 1) For i = a + 1 To nbpages On Error Resume Next ActiveSheet.HPageBreaks(i).Delete Next 'reconstruction des tableaux avec entete en dessous de l'original For i = LBound(tbsheet) To UBound(tbsheet) If i < UBound(tbsheet) Then Set c = Union(entete, .Range(tbsheet(i))) Else Set c = .Range(tbsheet(i)) c.Copy .Range(col1 & dl2) dl2 = .UsedRange.Cells(.UsedRange.Cells.Count).Row 'Là on est sur!!!! If i < UBound(tbsheet) Then ActiveWindow.SelectedSheets.HPageBreaks.Add Before:=.UsedRange.Cells(.UsedRange.Cells.Count) Next 'si on veut simplement imprimer 'on imprime les pages reconstruite '.Range(.Range("A" & dl3), .UsedRange.Cells(.UsedRange.Cells.Count)).PrintPreview 'ou printout sur ton imprimante pdf Set rg = .Range(.Range(col1 & dl3), .UsedRange.Cells(.UsedRange.Cells.Count)) 'ça c'est la plage des tableaux reconstruits 'export pdf rg.ExportAsFixedFormat Type:=xlTypePDF, Filename:=chemin, _ Quality:=xlQualityStandard, _ IncludeDocProperties:=True, _ IgnorePrintAreas:=False, _ OpenAfterPublish:=False Set rg = Nothing 'et enfin on supprime les pages reconstruites pour revenir à l'original .Range(.Range(col1 & dl3), Range(col2 & Rows.Count)).EntireRow.Delete Shift:=xlUp End With End Sub
' si tu utilise l'imprimante bullzip en ayant simplement coché dans les parametres de bullzip "ajouter au document existant
Sub testy()
With ActiveSheet
'dl = .UsedRange.Rows.Count 'Attention c'est pas bon si le usedrange ne commence pas en ligne 1
dl = .UsedRange.Cells(.UsedRange.Cells.Count).Row 'Là on est sur!!!!
nbpages = (.HPageBreaks.Count + 1) * (.VPageBreaks.Count + 1)
'impression des pages (count-1)
.PageSetup.PrintTitleRows = "$1:$4"
ActiveSheet.PrintOut from:=1, To:=nbpages - 1 'On imprime tout jusqu'à l'avant dernière page
'impression de la derniere page
.PageSetup.PrintTitleRows = "" 'on enlève les entêtes
ActiveSheet.PrintOut from:=nbpages, To:=nbpages 'On imprime la dernière page
End With
End Sub