Option Explicit
Sub Intercaler(WKS As String)
Dim Memo As String, PremLig As Long, DerLig As Long, Extgauche As Integer, ExtDroite As Integer, y As Long, x As Long
Dim Fin As Long, Debut As Long, Gauche As Integer, Droite As Integer, Ppage As Long, PpageL As Integer
Dim MemoT()
Dim ThisWKS As Worksheet
Application.ScreenUpdating = False
Set ThisWKS = ActiveSheet
With Worksheets(WKS)
.Select
ActiveWindow.View = xlPageBreakPreview
Memo = .PageSetup.PrintArea
If Memo = "" Then
PremLig = .UsedRange.Row
DerLig = .Range("A1").SpecialCells(xlCellTypeLastCell).Row
Extgauche = .UsedRange.Column
ExtDroite = Extgauche + .UsedRange.Columns.Count - 1
Else
MemoT = Split(Memo, "$")
Extgauche = Range(MemoT(1) & "1").Column
PremLig = Left(MemoT(2), Len(MemoT(2)) - 1) * 1
ExtDroite = Range(MemoT(3) & "1").Column
DerLig = MemoT(4) * 1
End If
y = .HPageBreaks.Count
x = .VPageBreaks.Count
Debut = 1
If y > 0 Or x > 0 Then
Gauche = Extgauche
If .PageSetup.Order = xlDownThenOver Then
For PpageL = 1 To x + 1
Debut = PremLig
If PpageL <= x Then
Droite = .VPageBreaks(PpageL).Location.Column - 1
Else
Droite = ExtDroite
End If
For Ppage = 1 To y + 1
If Ppage > y Then
Fin = DerLig
Else
Fin = .HPageBreaks(Ppage).Location.Row - 1
End If
.PageSetup.PrintArea = Range(Cells(Debut, Gauche), Cells(Fin, Droite)).Address
'Lancer l'impression des 2 feuilles
Sheets(Array(WKS, "Verso")).PrintOut Copies:=1, Collate:=True
.Select
.PageSetup.PrintArea = Memo
Debut = Fin + 1
Next Ppage
Gauche = Droite + 1
Next PpageL
Else
Debut = PremLig
For Ppage = 1 To y + 1
Gauche = Extgauche
If Ppage > y Then
Fin = DerLig
Else
Fin = .HPageBreaks(Ppage).Location.Row - 1
End If
For PpageL = 1 To x + 1
If PpageL <= x Then
Droite = .VPageBreaks(PpageL).Location.Column - 1
Else
Droite = ExtDroite
End If
.PageSetup.PrintArea = Range(Cells(Debut, Gauche), Cells(Fin, Droite)).Address
'Lancer l'impression des 2 feuilles
Sheets(Array(WKS, "Verso")).PrintOut Copies:=1, Collate:=True
.Select
.PageSetup.PrintArea = Memo
Gauche = Droite + 1
Next PpageL
Debut = Fin + 1
Next Ppage
End If
Else
Sheets(Array(WKS, "Verso")).PrintOut Copies:=1, Collate:=True
.Select
End If
.PageSetup.PrintArea = Memo
End With
ActiveWindow.View = xlNormalView
ThisWKS.Select
End Sub
