ich kopiere 3 Diagramme aus 3 Arbeitsblättern (A,B,C) und füge diese dann auf ein neues Arbeitsblatt (ABCJPG) ein. Dieses generiere ich im Querformat und der Umbruchvorschau.
Da ich ein Druckfertiges Arbeitsblatt erhalten möchte müsste ich nun noch irgendwie die Bilder automatisch auf die Blattgröße (A4) bringen und zentriert anordnen.
Bisher habe ich die Bilder in einem "L" angeordnet durch die Größe ergibt das natürlich ca. 30 gestückelte Seiten.. Wie schaffe ich es die Bilder über VBA jeweils auf eine Seite zu skalieren ?
Danke & Liebe Grüße
Hier mein bisheriger Code (das meiste ist mit dem Rekorder aufgenommen)
Beispieldatei:
https://www.herber.de/bbs/user/149506.xlsm
Sub safe()
Dim wksExportTabelle As Worksheet
Dim wbkNeu As Workbook
On Error Resume Next
Application.ScreenUpdating = False
Sheets.Add(After:=Sheets(Sheets.Count)).Name = "ABCJPG"
Sheets("ABCJPG").Select
ActiveWindow.Zoom = 50
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.PrintTitleRows = ""
.PrintTitleColumns = ""
End With
Application.PrintCommunication = True
ActiveSheet.PageSetup.PrintArea = ""
Application.PrintCommunication = False
With ActiveSheet.PageSetup
.LeftHeader = ""
.CenterHeader = ""
.RightHeader = ""
.LeftFooter = ""
.CenterFooter = ""
.RightFooter = ""
.LeftMargin = Application.InchesToPoints(0.7)
.RightMargin = Application.InchesToPoints(0.7)
.TopMargin = Application.InchesToPoints(0.787401575)
.BottomMargin = Application.InchesToPoints(0.787401575)
.HeaderMargin = Application.InchesToPoints(0.3)
.FooterMargin = Application.InchesToPoints(0.3)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = xlPrintNoComments
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Orientation = xlLandscape
.Draft = False
.PaperSize = xlPaperA4
.FirstPageNumber = xlAutomatic
.Order = xlDownThenOver
.BlackAndWhite = False
.PrintErrors = xlPrintErrorsDisplayed
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.ScaleWithDocHeaderFooter = True
.AlignMarginsHeaderFooter = True
.EvenPage.LeftHeader.Text = ""
.EvenPage.CenterHeader.Text = ""
.EvenPage.RightHeader.Text = ""
.EvenPage.LeftFooter.Text = ""
.EvenPage.CenterFooter.Text = ""
.EvenPage.RightFooter.Text = ""
.FirstPage.LeftHeader.Text = ""
.FirstPage.CenterHeader.Text = ""
.FirstPage.RightHeader.Text = ""
.FirstPage.LeftFooter.Text = ""
.FirstPage.CenterFooter.Text = ""
.FirstPage.RightFooter.Text = ""
End With
Application.PrintCommunication = True
ActiveWindow.View = xlPageBreakPreview
Cells.Select
With Selection.Interior
.Pattern = xlSolid
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark1
.TintAndShade = 0
.PatternTintAndShade = 0
End With
Sheets("A").Select
Range("B2:Y63").Select
Selection.Copy
Sheets("ABCJPG").Select
Range("B2").Select
ActiveSheet.Pictures.Paste.Select
Sheets("B").Select
Range("B2:Y63").Select
Selection.Copy
Sheets("ABCJPG").Select
Range("AH2").Select
ActiveSheet.Pictures.Paste.Select
Sheets("C").Select
Range("B2:AH63").Select
Selection.Copy
Sheets("ABCJPG").Select
Range("B74").Select
ActiveSheet.Pictures.Paste.Select
Set wksExportTabelle = ActiveWorkbook.Worksheets("ABCJPG")
wksExportTabelle.Copy
Set wbkNeu = ActiveWorkbook
With wbkNeu.Worksheets("ABCJPG").UsedRange
.Value = .Value
End With
wbkNeu.SaveAs wksExportTabelle.Parent.Path & "\" & "ABC" & Date & ".xlsx"
Application.DisplayAlerts = False
ActiveWorkbook.Close SaveChanges:=True
Set wbkNeu = Nothing
Set wksExportTabelle = Nothing
Application.DisplayAlerts = False
Worksheets("ABCJPG").Activate
ActiveWindow.Zoom = 30
ActiveSheet.Name = Date
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub