Sub Testseparieren()
Dim QWB As Workbook
Dim ZWB As Workbook
Dim SMPfad As String
SMPfad = ("C:\Test\Blacklist Test.xlsx")
Application.ScreenUpdating = True
Application.EnableEvents = True
Dim oldCalculation As Long
oldCalculation = Application.Calculation
On Error GoTo Fehler
Application.Calculation = xlCalculationManual
ActiveSheet.Name = "Original"
SSe:
Set ZWB = ActiveWorkbook
If IsWorkbookOpen("Blacklist Test") Then
Set QWB = Workbooks("Blacklist Test")
If MsgBox("Blacklist Test schlie?en?", vbYesNo) = vbYes Then
QWB.Close False
Set QWB = Nothing
Else
GoTo Fehler
End If
Else
MsgBox "Nicht offen"
End If
Stop
Dim lngCounter As Long
Set QWB = Workbooks.Open(SMPfad)
For lngCounter = 1 To QWB.Sheets.Count
QWB.Sheets(lngCounter).Copy After:=ZWB.Sheets(ZWB.Sheets.Count)
Next lngCounter
Set ZWB = Nothing
Set QWB = Nothing
Stop
Set QWB = Workbooks.Open(SMPfad)
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
Set QWB = Nothing
Fehler:
End Sub