Hallo zusammen,
wenn die Aufgabe immer wieder erledigt werden soll, wovon ich ausgehe, dann würde ich etws mehr Code einsetzen.
Als erstes könnte ich mir vorstellen, dass eventuell schon vorhandene Tabellenblätter gelöscht werden sollen.
Das würde folgender Code machen:
Code:
Dim i As Long
Dim wks As Worksheet
On Error GoTo Fehler_Meldung
Application.DisplayAlerts = False
Application.ScreenUpdating = False
If MsgBox("Sollen die Tabellenblätter wirklich gelöscht werden?", vbYesNo, "Tabellenblätter löschen?") = vbYes Then
For Each wks In ThisWorkbook.Sheets
If wks.Name <> "Bewertung MuG" Then
wks.Delete
End If
Next
End If
Fehler_Meldung:
Application.DisplayAlerts = True
Application.ScreenUpdating = True
If Err Then MsgBox "Fehler: " & i & " " & Err.Number & vbLf & Err.Description
End Sub
Mit obiger Routine werden alle Blätte außer
Bewertung MuG gelöscht.
Zum Kopieren gehe ich einen ganz anderen Weg als die bisher gezeigten Lösungen.
Ich kopier einfach das ganze Blatt und lösch danach die nicht benötigten Spalten, so werden keine Formate zerschossen.
Und das geschieht dann mit diesem Code:
Code:
Sub Blatt_kopieren()
Dim i As Long
Dim wksA As Worksheet
Set wksA = ActiveSheet
Application.ScreenUpdating = False
For i = 4 To 20
wksA.Copy After:=Sheets(Sheets.Count)
With ActiveSheet
Select Case i
Case 4
.Name = Cells(1, 4) & "," & Cells(2, 4)
.Range(.Cells(1, i + 1), .Cells(1, 20)).EntireColumn.Delete
Case 5 To 19
.Name = Cells(1, i) & "," & Cells(2, i)
Union(.Range(.Cells(1, 4), .Cells(1, i - 1)), .Range(.Cells(1 + i), .Cells(1, 20))).EntireColumn.Delete
Case 20
.Name = Cells(1, 20) & "," & Cells(2, 20)
.Range(.Cells(1, 4), .Cells(1, 19)).EntireColumn.Delete
End Select
End With
Next
Application.ScreenUpdating = True
End Sub
Das der Code in der Beispieldatei funktioniert, habe ich dem Umstand zu verdanken, dass sich die Verbundenen Zellen nicht im zu löschen Bereich befinden.
Der Code ist statisch auf 20 Spalten eingestellt. Sollte eine flexible Lösung nötig sein, dann müssen im Code einige Anpassungen gemacht werden.