AW: Tabellenblatt mit Inhalt kopieren
16.03.2011 13:03:30
Ralf
Hallo Hajo,
nö, das hat nicht funktioniert.
Das Makro sieht derzeit so aus:
Sub Speichern_unter3()
'* H. Ziplies, Karin Mohnhaupt *
'* 16.08.10 *
'* Rückfragen an HajoZiplies@web.de *
'* http://Hajo-Excel.de/
' Kopie einer Datei ohne Formeln mit Format, Tabellen nicht geschützt
Dim InI As Integer
' Neue Arbeitsmappe erstellen, Diese Arbeitsmappe ist die aktive
Workbooks.Add
' Arbeitsmappe mit Code
With ThisWorkbook
' neue Arbeitsmappe unter einem neuen Namen speichern
' Name = alter Name davor aber "Kopie_von_"
' Unterscheidung der Excelversion
' bis einschl. Version 2003
'ActiveWorkbook.SaveAs .Path & "\Kopie_von_" & .Name
' ab Version 2007 wird der Dateityp geändert auf XLSX
'ActiveWorkbook.SaveAs .Path & "\Kopie_von_" & Left(.Name, _
' InStrRev(.Name, ".") - 1) & ".xlsx", _
' FileFormat:=xlOpenXMLWorkbook
' Schleife über alle Register dieser Arbeitsmappe
For InI = .Worksheets.Count To 1 Step -1
' Prüfen ob Druckbereich festgelegt
If .Worksheets(InI).PageSetup.PrintArea "" Then
' neue Tabelle in der aktiven Arbeitsmappe
' mit dem Namen der Tabelle aus der Arbeitsmappe
' mit dem Code
Worksheets.Add.Name = .Worksheets(InI).Name
' kopieren Tabelle in der Arbeitsmappe mit Code kopieren
.Worksheets(InI).Range("Druckbereich").Copy
' Einfügen in der aktiven Arbeitsmappe
With ActiveWorkbook.ActiveSheet.Range("A1")
' Werte übertragen
.PasteSpecial Paste:=xlPasteValues
' Formate übertragen
.PasteSpecial Paste:=xlFormats
End With
End If
Next InI
' Zwischenspeicher löschen
Application.CutCopyMode = False
' Bildschirmitteilungen abschalten
' keine Abfrage ob Tabelle gelöscht werden soll
Application.DisplayAlerts = False
' alle Tabellen löschen die durch Datei Neu vorhanden sind
' eine neue Datei wird laut Standard mit 3 Tabellen erstellt
For InI = 1 To Application.SheetsInNewWorkbook
' Löschen der Tabelle
Worksheets(ActiveWorkbook.Worksheets.Count).Delete
Next InI
' Bildschirmitteilungen einschalten
Application.DisplayAlerts = True
' Mitteillung das Kopie erstellt wurde
If Val(Application.Version) = 2007
MsgBox "Reine Datentabelle gespeichert als: " & .Path _
& "\Kopie_von_" & Left(.Name, InStrRev(.Name, ".") - 1) _
& ".xlsx"
End If
' Dateikopie schließen mit speichern
ActiveWorkbook.Close True
End With
'Spaltenbreite und Zeilenhöhe automatisch anpassen
With Cells
.Columns.AutoFit
.Rows.AutoFit
End With
'Dialogfenster Speichern unter ... aufrufen
Application.Dialogs(xlDialogSaveAs).Show
End Sub
Vielleicht kannst Du für mich den Block für Spaltenbreite und Zeilenhöhe an der richtigen Stelle einfügen.
Vielen Dank.
Gruß
Ralf