Nur sichtbare sheets kopieren

Sub Kopieren() Dim Wiederholungen As Integer, Quelldatei As String, i As Integer, Neuer_Dateiname Dim x As Integer Wiederholungen = 6 x = 13 Application.ScreenUpdating = False Quelldatei = ActiveWorkbook.name Workbooks.Add Do Until Wiederholungen = 13 Worksheets.Add Wiederholungen = Wiederholungen + 1 Loop Wiederholungen = 6 i = 1 For Wiederholungen = 6 To x Sheets(i).name = Workbooks(Quelldatei).Sheets(Wiederholungen).name Workbooks(Quelldatei).Sheets(Wiederholungen).Cells.Copy Sheets(i).Range("A1").PasteSpecial Paste:=xlPasteValues Sheets(i).Range("A1").PasteSpecial Paste:=xlPasteFormats i = i + 1 Next i = MsgBox("SpeichernAktion kann nicht rückgängig gemacht werden!" & Chr(13) & _ "" & Chr(13) & _ "Sicher? Dann OK, sonst ABBRECHEN" & Chr(13), 1 + vbExclamation, "Festwerte in neue Datei speichern") If i = 2 Then Exit Sub Neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe, *.xls") If Neuer_Dateiname = False Then Exit Sub ActiveWorkbook.SaveAs FileName:=Neuer_Dateiname End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo metman,
in Deinem Vba-Code kopierst Du keine Tabellen, sondern den Zellinhalte von einer in eine andere Tabelle. Die in den Tabellen enthaltenen Grafiken sind Objekte, die eben bei diesem Vorgehen nicht mitkopiert werden.Mach es so:

Sub Kopieren()
Dim Beginn As Integer, Wiederholungen As Integer, i As Integer, x As Integer, _
Quelldatei As Workbook, Zieldatei As Workbook, _
sh As Object, neuer_Dateiname As Variant
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
''Wiederholungen = 6
''x = 13
Wiederholungen = 1
x = 7
Set Quelldatei = ThisWorkbook
For Beginn = Wiederholungen To x
Set sh = Quelldatei.Sheets(Beginn)
If sh.Visible Then
''wenn Tabelle sichtbar
If Zieldatei Is Nothing Then
''1. Tabelle kopieren
sh.Copy
Set Zieldatei = Application.ActiveWorkbook
Else
''weitere Tabellen kopieren
sh.Copy after:=Zieldatei.Sheets(Zieldatei.Sheets.Count)
End If
End If
Next Beginn
i = MsgBox("SpeichernAktion kann nicht rückgängig gemacht werden!" & Chr(13) & _
"" & Chr(13) & _
"Sicher? Dann Ja, sonst Nein" & Chr(13), vbYesNo + vbExclamation, "Festwerte in neue Datei speichern")
If i = vbYes Then
neuer_Dateiname = Application.GetSaveAsFilename(InitialFileName:="", fileFilter:="Excel-Arbeitsmappe, *.xls")
If neuer_Dateiname = False Then
Else
ActiveWorkbook.SaveAs Filename:=neuer_Dateiname
End If
End If
Set Quelldatei = Nothing
Set Zieldatei = Nothing
Set sh = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
End Sub

Gruß von luschi
aus klein-Paris

Beliebteste Forumthreads (12 Monate)

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread