Mise en page automatique + zone d'impression

Bonjour,

J ai recuperé une macro que j ai un peu modifiée qui me copie chaque onglet, dans un nouveau classeur puis me l'enregistre dans un repertoire specifique.

Le "Hic" c est que ces nouveaux classeurs ne sont pas mise en page.
j appel donc une macro de mise page qui est censée ajuster la zone d'impression automatiquement a la derniere ligne et a la derniere collone, cela fonctionne + ou - mais cela reste tres long vu qu'il y + de 120 onglets, qui generent donc 120 fichiers, et avant chaque enregistrement il y la mise en page est faite (donc 120 mises en page). a peu pres 2 cigarettes et un café...

Je me demandais donc si cela etait possible de faire appel a un classeur "modele" avec une mise en page predefinie, ce qui je pense nous ferais gagner du temps.

Ensuite je n'arrive pas a ajuster ma zone d'impression correctement a chaque fois j'ai minimum quatre pages...
j'ai retourner le probleme dans tout les sens mais je ne trouve point.


je colle mon code ci dessous.


May the FORCE BE WITH YOU!!!


Sub saveOnglet()
Dim ws
Dim newWk As Workbook


Dim TD As String ' Nom constant
TD = "Encours à facturer 122009"

MsgBox (" Une cigarette ?")
For Each ws In Worksheets
Set newWk = Workbooks.Add(xlWBATWorksheet)
ws.Copy newWk.Sheets(1)
Dim DPT As String 'DPT variable
DPT = Range("A3").Value
Call Set_Print_Area
'Chemin du Repertoire
newWk.saveas ("H:\REP_EQUI\CONTGEST\Réel 09\Encours à Facturer\122009\Détail par BTK\" & DPT & "_" & ws.Name & "_" & TD & ".xls")



newWk.Close
Set newWk = Nothing
Next ws




End Sub



'Cette Macro crée une mise en page automatique pour chaque fichier avant son enregistrement elle doit être lancer à partir de "save onglet" qui l'appellera au moment oportun

Sub Set_Print_Area()
Dim x As Long, lastCell As Range, LR As Long
x = ActiveSheet.UsedRange.Columns.Count
Set lastCell = Cells.SpecialCells(xlCellTypeLastCell).Offset(1, 0)
LR = lastCell.Row
Do Until Application.Count(Range(Cells(LR, 2), Cells(LR, 256))) <> 0
Set lastCell = lastCell.Offset(-1, 0)
LR = lastCell.Row
Loop
ActiveSheet.PageSetup.PrintArea = Range(Cells(1, 1), lastCell).Address
With ActiveSheet.PageSetup
.PrintTitleRows = "$1:$2"
.PrintTitleColumns = ""
End With
ActiveSheet.PageSetup.PrintArea = "$A$1:$T$189"
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = "&A"
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.787401575)
.RightMargin = Application.InchesToPoints(0.787401575)
.TopMargin = Application.InchesToPoints(0.984251969)
.BottomMargin = Application.InchesToPoints(0.984251969)
.HeaderMargin = Application.InchesToPoints(0.4921259845)
.FooterMargin = Application.InchesToPoints(0.4921259845)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = True
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.Zoom = False
.FitToPagesWide = 1
.FitToPagesTall = 15
.PrintErrors = xlPrintErrorsDisplayed
End With
End Sub