Tabelle in neue Tabelle kopieren...
11.10.2012 12:07:20
Waldtraut
ich möchte per UserForm Tabellenblätter auswählen und in eine neue Tabelle kopieren.
Den Code dazu habe ich mir "gegoogelt".
Allerdings werden wohl nur die Formeln, Werte und Formate kopiert (lt. Anmerkung).
Ich möchte aber die ausgewählten Tabellenblätter insgesamt kopieren.
Wer kann mir helfen und den Code dahingehend modifizieren? Danke für eure Hilfe!
Private Sub Tabellen_kopieren()
Dim wkbNeu As Workbook
Dim wksNeu As Worksheet
Dim strDateiName As String
Dim i As Integer, k As Integer
Dim Objekt As Shape
'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
' Ausgewählte Tabellenblätter in die Neue Mappe kopieren
Application.ScreenUpdating = False
With Me.Blätter
i = Application.SheetsInNewWorkbook
'Application.SheetsInNewWorkbook = 1
Set wkbNeu = Workbooks.Add(1)
'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 ' überträgt Werte
.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
'ThisWorkbook.Close savechanges:=False
Unload Me
Application.ScreenUpdating = True
End Sub