Wenn ich die Kalenderwoche in meiner Tabelle abändere, werden zwei neue Blätter erstellt.
Daraufhin werden Inhalt und Format kopiert und in die Blätter eingefügt und dann eben noch die Druckbereiche so festgelegt wie in der Originaldatei.
Hab hier mal jetzt noch den restlichen Code eingefügt um das ganze ein bisschen anschaulicher zu machen.
Private Sub Worksheet_Change(ByVal Target As Range)
If Intersect(Target, Cells(4, 72)) Is Nothing Then Exit Sub
neueKW
End Sub
Sub neueKW()
'Variablendeklaration
Dim abc As Worksheet
Set abc= ThisWorkbook.Worksheets("abc")
Dim def As Worksheet
Set def = ThisWorkbook.Worksheets("def")
Application.ScreenUpdating = False
'Hier werden die beiden Tabellenblätter für abc und def erstellt
ThisWorkbook.Worksheets.Add.Name = "KW " & Cells(4, 72) & " abc"
ThisWorkbook.Worksheets.Add.Name = "KW " & Cells(4, 72) & " def"
Dim abcNeu As Worksheet
Set abcNeu = Worksheets("KW " & Cells(4, 72) & " abc")
Dim defNeu As Worksheet
Set defNeu = Worksheets("KW " & Cells(4, 72) & " def")
'Hier werden die beiden Tabellenblätter nach hinten geschoben um ganz hinten zu stehen
abcNeu.Move After:=Sheets(8)
defNeu.Move After:=Sheets(8)
'Hier wird der Inhalt des Tabellenblatts "abc" kopiert
With abc
.Range(.Cells(1, 1), .Cells(1048576, 16384)).Copy
End With
'Hier wird der Inhalt dann in das neue Tabellenblatt eingefügt (abcNeu)
With abcNeu
.Cells(1, 1).PasteSpecial Paste:=xlValues
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
End With
copyPageSetup abc, abcNeu
'Hier wird der Inhalt des Tabellenblatts "def" kopiert
With def
.Range(.Cells(1, 1), .Cells(1048576, 16384)).Copy
End With
'Hier wird der Inhalt dann in das neue Tabellenblatt eingefügt (def)
With defNeu
.Cells(1, 1).PasteSpecial Paste:=xlValues
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
End With
copyPageSetup def, defNeu
'Hier werden nur die 0-Zellen deaktiviert
ActiveWindow.DisplayZeros = False
'Hier wird die Bildschirmaktualisierung wieder aktiviert
Application.ScreenUpdating = True
'Hier werden bis zum Ende der Sub nur noch die jeweiligen Zellen ausgewählt um direkt mit Eintragungen beginnen zu können.
ActiveSheet.Cells(7, 75).Select
With abcNEu
.Select
.Cells(7, 75).Select
End With
End Sub
|