Hallo,

hier noch eine Idee zu einer etwas aufgeräumten Version, die ich leider nicht testen konnte und auch nicht genau weiß, ob sie das macht, was Du möchtest.

Schau sie Dir einfach mal an, vielleicht hilft es Dir irgendwie weiter....

Sub TestseparierenNeu()
 Dim QWB As Workbook      ' Quellworkbook Suchmeldungen
 Dim ZWB As Workbook      ' Zielworkbook Meldungen
 Dim SMPfad As String     ' Pfad zum Quellworkbook
 Dim oldCalculation As Long
 Dim lngCounter As Long
 
 SMPfad = ("C:\Test\Blacklist Test.xlsx")

' Zum Beschleunigen Ausschalten
 With Application
    .ScreenUpdating = False
    .EnableEvents = False
' Caculation auf Zustand prüfen und ausschalten. Bei Fehler in alten Zustand zurücksetzen
    oldCalculation = .Calculation
    .Calculation = xlCalculationManual
 End With

'Name des Sheets ändern
 ActiveSheet.Name = "Original"

' Sheet Blacklist in Sheet einfügen
 Set ZWB = ActiveWorkbook
 
 
' Kontrolle ob Datei Blacklist für FIS Meldungen schon offen
 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        ' Schließen der Suchmeldungen
        GoTo Fehler
    End If
   Else
' Nicht offen
    Set QWB = Workbooks.Open(SMPfad)
    If Workbooks("Blacklist Test") Is Nothing Then GoTo Fehler
 End If

 
' Öffnen des Pfades und Kopieren aller Sheets in aktives Workbook
 For lngCounter = 1 To QWB.Sheets.Count
    QWB.Sheets(lngCounter).Copy After:=ZWB.Sheets(ZWB.Sheets.Count)
 Next lngCounter

'Nur wenn oben nicht funktioniert, einzele Sheets kopieren ???????

 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        ' Schließen der Blacklist


Fehler:
 Set ZWB = Nothing
 Set QWB = Nothing
 
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = oldCalculation
 End With

End Sub

viele Grüße

Karl-Heinz