Sub TestseparierenNeu()
Const sMappe As String = "Blacklist Test.xlsx"
Dim QWB As Workbook
Dim ZWB As Workbook
Dim SMPfad As String
Dim oldCalculation As Long
Dim lngCounter As Long
SMPfad = "C:\Test\" & sMappe
SMPfad = "C:\Users\voltm\Desktop\" & sMappe
With Application
.ScreenUpdating = False
.EnableEvents = False
oldCalculation = .Calculation
.Calculation = xlCalculationManual
End With
ActiveSheet.Name = "Original"
Set ZWB = ActiveWorkbook
On Error Resume Next
Set QWB = Workbooks(sMappe)
On Error GoTo 0
If Not QWB Is Nothing Then
If MsgBox(sMappe & " schließen?", vbYesNo) = vbYes Then
QWB.Close False
GoTo Kopieren
End If
GoTo ende
Else
Set QWB = Workbooks.Open(SMPfad)
If QWB Is Nothing Then GoTo ende
End If
Kopieren:
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
ende:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = oldCalculation
End With
End Sub