Tabelle mit Formaten, Formeln, Werten kopieren...
08.10.2012 10:26:27
Ina
ich möchte aus einer Mappe verschiedene Tabellenblätter aussuchen und komplett mit Formeln, Werten uns allen Formaten (auch Zellfärbung) in eine neue Mappe kopieren (Codeschnipsel weiter unten).
Das funktioniert auch fast... Nur die Zellfärbungen werden einfach nicht übernommen.
Wer kann mir da weiterhelfen und den Code dahingehend umbasteln?
LG Ina
Option Explicit
Dim j As Integer
Private Sub Abbrechen_Click()
Unload Me
End Sub
Private Sub Blätter_Change()
Dim i As Integer
j = 0
With Me.Blätter
For i = 0 To .ListCount - 1
If .Selected(i) = True Then
j = j + 1
End If
Next i
End With
If j > 0 Then
Me.Speichern.Enabled = True
Else
Me.Speichern.Enabled = False
End If
End Sub
Private Sub Speichern_Click()
Dim wkbNeu As Workbook
Dim wksNeu As Worksheet
Dim strDateiName As String
Dim i As Integer, k As Integer
'Speichername und SpeicherstrPfad abfragen
strDateiName = ThisWorkbook.Path & "\Kopie von " & ThisWorkbook.Name
strDateiName = Application.GetSaveAsFilename(InitialFileName:=strDateiName, FileFilter:="Microsoft Excel-Arbeitsmappe (*.xls), *.xls")
If strDateiName = "Falsch" Then Exit Sub
Application.ScreenUpdating = False
With Me.Blätter
' Ausgewählte Tabellenblätter in die Neue Mappe kopieren
i = Application.SheetsInNewWorkbook
Application.SheetsInNewWorkbook = 1
Set wkbNeu = Workbooks.Add
Application.SheetsInNewWorkbook = i
For i = 0 To .ListCount - 1
If .Selected(i) Then
If k Then wkbNeu.Sheets.Add After:=wksNeu
k = k + 1
Set wksNeu = wkbNeu.Sheets(k)
wksNeu.Name = ThisWorkbook.Sheets(.List(i)).Name
ThisWorkbook.Sheets(.List(i)).UsedRange.Copy
With wksNeu.Cells(1)
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormulas ' überträgt Zellen mit Formeln
.PasteSpecial xlPasteFormats ' überträgt Formate
.PasteSpecial xlPasteColumnWidths ' überträgt Spaltenbreite
End With
Application.Goto Reference:=Cells(1)
Application.CutCopyMode = False
End If
Next i
End With
'Neue Mappe Speichern
wkbNeu.SaveAs Filename:=strDateiName
Unload Me
Application.ScreenUpdating = True
End Sub
Private Sub UserForm_Activate()
Dim sh As Worksheet
With Me.Blätter
.Clear
.MultiSelect = fmMultiSelectMulti
.ListStyle = fmListStyleOption
For Each sh In ThisWorkbook.Worksheets(Array("Tabelle1", "Tabelle2", "Tabelle3", "Tabelle4", "Tabelle7"))
.AddItem sh.Name
Next sh
End With
Me.Speichern.Enabled = False
End Sub