Sub
TestseparierenNeu()
Dim
QWB
As
Workbook
Dim
ZWB
As
Workbook
Dim
SMPfad
As
String
Dim
oldCalculation
As
Long
Dim
lngCounter
As
Long
SMPfad = (
"C:\Test\Blacklist Test.xlsx"
)
With
Application
.ScreenUpdating =
False
.EnableEvents =
False
oldCalculation = .Calculation
.Calculation = xlCalculationManual
End
With
ActiveSheet.Name =
"Original"
Set
ZWB = ActiveWorkbook
If
Not
Workbooks(
"Blacklist Test"
)
Is
Nothing
Then
Set
QWB = Workbooks(
"Blacklist Test"
)
If
MsgBox(
"Blacklist Test schließen?"
, vbYesNo) = vbYes
Then
QWB.Close
False
GoTo
Fehler
End
If
Else
Set
QWB = Workbooks.Open(SMPfad)
If
Workbooks(
"Blacklist Test"
)
Is
Nothing
Then
GoTo
Fehler
End
If
For
lngCounter = 1
To
QWB.Sheets.Count
QWB.Sheets(lngCounter).Copy After:=ZWB.Sheets(ZWB.Sheets.Count)
Next
lngCounter
QWB.Worksheets(
"Blacklist"
).Cells.Copy
With
ZWB
.Sheets.Add After:=.ActiveSheet
.ActiveSheet.Name =
"Blacklist"
.ActiveSheet.Range(
"A1"
).PasteSpecial Paste:=xlPasteAllUsingSourceTheme
Application.CutCopyMode =
False
End
With
QWB.Close
False
Fehler:
Set
ZWB =
Nothing
Set
QWB =
Nothing
With
Application
.ScreenUpdating =
True
.EnableEvents =
True
.Calculation = oldCalculation
End
With
End
Sub