Private
Sub
Worksheet_Change(
ByVal
Target
As
Range)
If
Intersect(Target, Cells(4, 72))
Is
Nothing
Then
Exit
Sub
neueKW
End
Sub
Sub
neueKW()
Dim
abc
As
Worksheet
Set
abc= ThisWorkbook.Worksheets(
"abc"
)
Dim
def
As
Worksheet
Set
def = ThisWorkbook.Worksheets(
"def"
)
Application.ScreenUpdating =
False
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"
)
abcNeu.Move After:=Sheets(8)
defNeu.Move After:=Sheets(8)
With
abc
.Range(.Cells(1, 1), .Cells(1048576, 16384)).Copy
End
With
With
abcNeu
.Cells(1, 1).PasteSpecial Paste:=xlValues
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
End
With
copyPageSetup abc, abcNeu
With
def
.Range(.Cells(1, 1), .Cells(1048576, 16384)).Copy
End
With
With
defNeu
.Cells(1, 1).PasteSpecial Paste:=xlValues
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
End
With
copyPageSetup def, defNeu
ActiveWindow.DisplayZeros =
False
Application.ScreenUpdating =
True
ActiveSheet.Cells(7, 75).
Select
With
abcNEu
.
Select
.Cells(7, 75).
Select
End
With
End
Sub