Funktionslose Datei - Bilder übernehmen
13.05.2015 15:01:47
matthias
ich kann mittels des nachfolgenden Code, eine Excelblatt komplett frei von jeglichen Funktionen machen. Alles andere aber wird konvertiert. (Druckbereiche, Formatierung etc.)
Das einzige Problem stellen Bilder dar, die werden nicht übernommen.
Kann man den Code noch irgendwie erweitern, sodass auch Bilder mitkonvertiert werden?
Sub Send_Blatt_kopieren_gesamt()
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
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, 158)).Address(ReferenceStyle:= _
xlA1)
End With
End Sub