Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1856to1860
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bild auf Seitengröße anpassen VBA

Bild auf Seitengröße anpassen VBA
01.12.2021 11:16:39
Nelinax
Hallo Zusammen,
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

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bild auf Seitengröße anpassen VBA
01.12.2021 17:24:19
volti
Hallo Nelinax,
hier mal eine Anregung, wie Du die drei Bereiche als Bild einfügen kannst und deren Position und Größe bestimmen kannst.
Habe dieses mit einer Extra-Funktion gelöst.
Hier mit zwei Möglichkeiten,
1. einmal ermittelte fest Größen (reicht ja vielleicht auch schon)
2. Anpassung entsprechend eines Zellbereichs
Wenn Du eine automatische Zentrierung haben möchtest, kannst Du die Top,Left-Positionen auch errechnen.
z.B. .Left = (ActiveWindow.Width \ 2 - .Width \ 2)
Code:

[Cc]

Sub safe() ' Dein Code Sheets("ABCJPG").Select ' Zieltabelle aktivieren KopiereBereich "A", "B2:Y63", "B2", 200, 200 ' 1. Kopie KopiereBereich "B", "B2:Y63", "AH2", 200, 200 ' 2. Kopie KopiereBereich "C", "B2:AH63", "B74", 200, 200 ' 3. Kopie ' Dein Code End Sub Sub KopiereBereich(sWSh As String, sBer As String, sZiel As String, _ iW As Integer, iH As Integer) ' Kopiert einen Bereich als Bild und formatiert dieses ThisWorkbook.Sheets(sWSh).Range(sBer).Copy ' Bereich kopieren ActiveSheet.Pictures.Paste.Select ' und als Bild einfügen With Selection.ShapeRange .LockAspectRatio = False ' Bild darf verzerrt werden .Top = Range(sZiel).Top ' Position oben .Left = Range(sZiel).Left ' Position links .Width = iW: .Height = iH ' Größe absolut ' .Width = Range(sZiel).Resize(1, 2).Width ' Breite an Zellbereich angepasst ' .Height = Range(sZiel).Resize(10, 1).Height ' Höhe an Zellbereich angepasst End With Application.CutCopyMode = False End Sub

_________________________
viele Grüße aus Freigericht 😊
Karl-Heinz

Anzeige
AW: Bild auf Seitengröße anpassen VBA
02.12.2021 10:01:01
Nelinax
Guten Morgen Karl-Heinz,
danke !
Hat prima funktioniert..
Liebe Grüße
Nelinax

312 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige