Mise en page automatique + zone d'impression
Medinho
-
m@rina Messages postés 23933 Date d'inscription Statut Contributeur Dernière intervention -
m@rina Messages postés 23933 Date d'inscription Statut Contributeur Dernière intervention -
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
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
A voir également:
- Mise en page automatique + zone d'impression
- Spouleur d'impression - Guide
- Alternative zone telechargement - Accueil - Outils
- Mise en forme conditionnelle excel - Guide
- Supprimer page word - Guide
- Réponse automatique thunderbird - Guide
1 réponse
Bonjour,
Ton code n'est pas optimisé non plus !
Si, comme je le comprends, tu veux juste imprimer en paysage, centré en largeur, avoir les lignes de titre qui se répètent sur toutes les pages, et imposer une page en largeur, tu n'as pas besoin de tout ça, et pas besoin de créer une zone d'impression qui est par défaut le contenu de la feuille.
Essaie ça par exemple :
Je ne pense pas que cette macro allonge beaucoup le temps d'exécution. Par ailleurs, ton premier code est-il optimisé ?... Peut être que c'est lui qui pêche...
m@rina
Ton code n'est pas optimisé non plus !
Si, comme je le comprends, tu veux juste imprimer en paysage, centré en largeur, avoir les lignes de titre qui se répètent sur toutes les pages, et imposer une page en largeur, tu n'as pas besoin de tout ça, et pas besoin de créer une zone d'impression qui est par défaut le contenu de la feuille.
Essaie ça par exemple :
Sub Set_Print_Area() With ActiveSheet.PageSetup .PrintTitleRows = "$1:$2" .CenterHeader = "&A" .CenterHorizontally = True .Orientation = xlLandscape .FitToPagesWide = 1 .FitToPagesTall = False End With End Sub
Je ne pense pas que cette macro allonge beaucoup le temps d'exécution. Par ailleurs, ton premier code est-il optimisé ?... Peut être que c'est lui qui pêche...
m@rina