Paste Spezial - Problem am konkreten Beispiel
12.04.2006 19:09:09
Mark
ich habe ein Problem mit dem folgendem Code. Dieser soll ein Kopie des Druckbereiches als neues Datei anlegen. Klappt auch! In diesem Druckbereich sind Bilder, Zeilenabstände und Schriftzeichen (hoch- und tief gestellt), die aber leider bei der Kopie verlorengehen. Habe es mit PASTE SPEZIAL versucht, funktioniert leidfer nicht richtig!
Bitte helft mir. Wo ist der Fehler. Wie kann ich es evtl besser machen.
Gruß
-Mark-
Private Sub cmd_speichern_Click()
Dim Verz As String, fn
Verz = Workbooks("Startseite.xls").Worksheets("Startseite").Range("a60")
fn = Application.GetSaveAsFilename(Verz & "\Projekte\", "Excel-Arbeitsmappe (*.xls),*.xls", , "Datei speichern")
If fn = False Then Exit Sub 'Abbruch des Menüpunktes "Speichern unter"
'Kopie einer Datei ohne Formeln mit Format mur Druckbereich, Register nicht geschützt
Dim InI As Integer
Application.SheetsInNewWorkbook = 1
Workbooks.Add
Application.SheetsInNewWorkbook = 3
With ThisWorkbook
' Datei mit Code
ActiveWorkbook.SaveAs Filename:=fn ' neue Datei Workbooks.Add
If fn = False Then Exit Sub
For InI = .Worksheets.Count To 1 Step -1 ' Anzahl Register in ThisWorkbook
If .Worksheets(InI).PageSetup.PrintArea <> "" Then
Sheets.Add
.Worksheets(InI).Range("Druckbereich").Copy
With ActiveWorkbook.ActiveSheet.Range("A1")
.PasteSpecial Paste:=xlPasteValues ' Werte
.PasteSpecial Paste:=xlFormats ' Formate
.PasteSpecial Paste:=8 ' Splatenbreite
End With
ActiveWorkbook.ActiveSheet.Name = .Worksheets(InI).Name
End If
Next InI
Application.CutCopyMode = False 'Zwischenspeicher löschen
Application.DisplayAlerts = False
Worksheets(ActiveWorkbook.Worksheets.Count).Delete
Application.DisplayAlerts = True
ActiveWindow.SmallScroll Down:=51
ActiveWorkbook.Worksheets(1).Range("A70").Select
ActiveWindow.SmallScroll Down:=-72
ActiveSheet.PageSetup.LeftHeader = Workbooks("Startseite.xls").Worksheets("startseite").Range("B44")
ActiveSheet.PageSetup.RightHeader = Format(Workbooks("Startseite.xls").Worksheets("startseite").Range("B48"), "DD.MM.YYYY")
ActiveWorkbook.Close True
MsgBox "Die Position wurde im Verzeichnis: " & fn & " gespeichert.", , "Speichern unter..."
End With
End Sub