Neue Exceldatei erstellen-Bilder mitkopieren
05.11.2015 13:44:33
Tobias
mit nachfolgenden Makro kann ich ein bestimmtes Blatt kopieren und in eine neue Exceldatei kopieren. Dabei werden nur Werte und Formate übernommen, aber leider keine Bilder.
Ich habe zwei Bilder in meinen Blatt die aber auch mit kopiert werden sollen.
Hat hierzu wer eine Idee?
Sub FUK_IBN()
Dim shZiel As Worksheet
Dim shQuelle As Worksheet
Dim psQuelle As PageSetup
Application.ScreenUpdating = False
Set shQuelle = ActiveSheet
Set psQuelle = shQuelle.PageSetup
Workbooks.Add
Set shZiel = ActiveSheet
shZiel.Name = ActiveSheet.Name
ActiveSheet.Name = "Aufstellung"
shQuelle.Cells.Copy
shZiel.Cells(1, 1).PasteSpecial xlPasteValues
shZiel.Cells(1, 1).PasteSpecial xlPasteFormats, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
With shZiel.PageSetup
.LeftMargin = psQuelle.LeftMargin
.TopMargin = psQuelle.TopMargin
.FooterMargin = psQuelle.FooterMargin
.LeftFooter = psQuelle.LeftFooter
.CenterFooter = psQuelle.CenterFooter
.LeftHeader = psQuelle.LeftHeader
.CenterHeader = psQuelle.CenterHeader
.LeftFooter = psQuelle.LeftFooter
.CenterFooter = psQuelle.CenterFooter
.RightFooter = psQuelle.RightFooter
.Orientation = psQuelle.Orientation
.PaperSize = psQuelle.PaperSize
.FitToPagesWide = psQuelle.FitToPagesWide
.FitToPagesTall = psQuelle.FitToPagesTall
.Zoom = psQuelle.Zoom
End With
shZiel.Columns("FA:FC").Delete
shZiel.Columns("ER:EY").Delete
shZiel.Columns("BQ:EL").Delete
Dim Zeile As Long, wks As Worksheet
Set wks = ActiveSheet
With wks
Zeile = .Cells(.Rows.Count, 1).End(xlUp).Row 'Letzte Zeile mit Daten in Spalte A
'Letzte Zeile mit nummerischem Wert finden
Do Until IsNumeric(.Cells(Zeile, 1).Text) Or Zeile = 10
Zeile = Zeile - 1
Loop
.PageSetup.PrintArea = .Range(.Cells(1, 1), .Cells(Zeile, 73)).Address(ReferenceStyle:=xlA1) _
End With
End Sub
Anzeige