AW: Seiten kopieren - nur xls-sheet ohne VBA
06.07.2007 00:20:10
fcs
Hallo Ron,
folgender Code dupliziert Tabellen der aktiven Datei mit praktisch allen Formatierungen und Seiteneinstellungen in eine neue Arbeitsmappe, wobei im Duplikat alle Formeln durch Werte ersetzt sind.
Alternative gäbe es auch die Möglichkeit jeweils die kompletten Tabellenblätter in die neue Datei zu kopieren und dann die Formeln durch die Werte zu ersetzen und vorhandenen Tabellenblatt-Code zu löschen. Allerdings hab ich die Prozeduren zum Löschen von VBA-Code ncht parat. Wenn du hier im Archiv suchst solltest du etwas entsprechendes finden.
Gruß
Franz
Sub TabellenDuplizierenOhneFormeln()
'Die Tabellen einer Arbeitsmappe werden dupliziert in eine neue Datei
'Dabei werden in Einzelschritten die Formate und die Daten in _
ein neues Tabellenblatt übertragen
Dim wbQuelle As Workbook, wbZiel As Workbook
Dim wksQ As Worksheet, wksZ As Worksheet
Dim Spalte As Integer, Zeile As Long
Dim FigurQ As Shape, Diagramm As Boolean
Dim arrTabellenQ, arrTabellenZ
arrTabellenQ = Array(1, 2, 3) 'Nummern der Tabellen, die kopiert werden sollen
'arrTabellenQ = Array("Antrag", "Tabelle2", "Tabelle3") 'Namen zu kopierender der Tabellen
arrTabellenZ = Array("Antrag", "Tabelle2", "Tabelle3") 'Namen der kopierten Tabellen
Set wbQuelle = ActiveWorkbook
Application.ScreenUpdating = False
For i = LBound(arrTabellenQ) To UBound(arrTabellenQ)
Set wksQ = wbQuelle.Worksheets(arrTabellenQ(i))
If i = LBound(arrTabellenQ) Then
' Neue Datei mit einem Tabellenblatt anlegen
Set wbZiel = Application.Workbooks.Add(Template:=xlWBATWorksheet)
Set wksZ = wbZiel.Worksheets(1)
Else
Set wksZ = wbZiel.Worksheets.Add(after:=wbZiel.Sheets(wbZiel.Sheets.Count))
End If
wksZ.Name = arrTabellenZ(i)
With wksQ
'Einstellungen von Seite einrichten übertragen
With .PageSetup
'Drucktitel und -bereich
wksZ.PageSetup.PrintTitleRows = .PrintTitleRows
wksZ.PageSetup.PrintTitleColumns = .PrintTitleColumns
wksZ.PageSetup.PrintArea = .PrintArea
'Inhalte von Kopf- und Fußzeilen
wksZ.PageSetup.LeftHeader = .LeftHeader
wksZ.PageSetup.CenterHeader = .CenterHeader
wksZ.PageSetup.RightHeader = .RightHeader
wksZ.PageSetup.LeftFooter = .LeftFooter
wksZ.PageSetup.CenterFooter = .CenterFooter
wksZ.PageSetup.RightFooter = .RightFooter
'Seitenränder
wksZ.PageSetup.LeftMargin = .LeftMargin
wksZ.PageSetup.RightMargin = .RightMargin
wksZ.PageSetup.TopMargin = .TopMargin
wksZ.PageSetup.BottomMargin = .BottomMargin
wksZ.PageSetup.HeaderMargin = .HeaderMargin
wksZ.PageSetup.FooterMargin = .FooterMargin
'andere Druckeinstellungen
wksZ.PageSetup.PrintHeadings = .PrintHeadings 'Spaltenköpfe
wksZ.PageSetup.PrintGridlines = .PrintGridlines 'Giternetzlinien
wksZ.PageSetup.PrintComments = .PrintComments 'Kommentare
wksZ.PageSetup.CenterHorizontally = .CenterHorizontally
wksZ.PageSetup.CenterVertically = .CenterVertically
wksZ.PageSetup.Orientation = .Orientation 'Hoch-/Querformat
wksZ.PageSetup.Draft = .Draft 'Druckqualität
wksZ.PageSetup.PaperSize = .PaperSize 'papiergröße
wksZ.PageSetup.FirstPageNumber = .FirstPageNumber '1.Seitenzahl
wksZ.PageSetup.Order = .Order 'Seitenreihenfolge bei vielen Spalten
wksZ.PageSetup.BlackAndWhite = .BlackAndWhite
wksZ.PageSetup.Zoom = .Zoom
End With
'Spaltenbreiten übertragen
For Spalte = 1 To .UsedRange.Column + .UsedRange.Columns.Count - 1
wksZ.Columns(Spalte).ColumnWidth = .Columns(Spalte).ColumnWidth
Next Spalte
.UsedRange.Copy
'Zellformate übertragen - funktioniert hier auch mit verbundenen Zellen
wksZ.Range(.UsedRange.Address).PasteSpecial Paste:=xlPasteFormats
'Zellinhalte übertragen
wksZ.Range(.UsedRange.Address).PasteSpecial Paste:=xlValues
'Zeilenhöhen übertragen
For Zeile = 1 To .UsedRange.Row + .UsedRange.Rows.Count - 1
wksZ.Rows(Zeile).RowHeight = .Rows(Zeile).RowHeight
Next Zeile
Application.CutCopyMode = False
'Grafische Elemente übertragen
For Each FigurQ In .Shapes
Select Case FigurQ.Type
Case msoChart
'Diagramme behalten beim Kopieren ihre Verknüpfung zur Ursprungstabelle
'mit etwas Aufwand kann man auch die Verknüpfungen beseitigen
'geht am einfachsten erst nach dem Speichern der neuen Daten
Diagramm = True
FigurQ.Copy
wksZ.Range(FigurQ.TopLeftCell.Address).Select
ActiveSheet.Paste
Case msoOLEControlObject
'Steuerelemente aus Toolbox, z.B. Buttons werden nicht übertragen
Case Else
FigurQ.Copy
wksZ.Range(FigurQ.TopLeftCell.Address).Select
ActiveSheet.Paste
End Select
Next FigurQ
Application.CutCopyMode = False
End With
Next
Application.ScreenUpdating = True
'Neue Datei speichern via Dialog
'Test = Application.Dialogs(xlDialogSaveAs).Show
wbZiel.SaveAs FileName:=wbQuelle.Path & "\Antrag_" & wbQuelle.Name
'Für Diagramme die Verknüpfung auf die neue Datei festlegen
If Diagramm = True And Test = True Then
wbZiel.ChangeLink Name:=wbQuelle.FullName, NewName:= _
wbZiel.FullName, Type:=xlExcelLinks
wbZiel.Save
End If
End Sub