Hallo Bernd,

ich glaube, ich weiß jetzt was Du möchtest. Die Blackliste soll entweder aufbleiben und nicht kopiert werden oder nach dem Kopieren geschlossen werden?!

Ich habe auch den festen Begriff "Blacklist.." in eine Konstante gepackt...

Vielleicht dann so:

Sub TestseparierenNeu()
 Const sMappe As String = "Blacklist Test.xlsx"
 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\" & sMappe
  
' 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
'1. Blacklist geöffnet, Abfrage ob schließen, Ja, ohne speichern schließen, weiter mit Kopieren.    Funktioniert
'2. Blacklist geöffnet, Abfrage ob schließen, Nein, goto Ende,                                       Funktioniert
'3  Blacklist ist nicht geöffnet, weiter mit Kopieren                                                Funktioniert nicht
   
' Kontrolle ob Datei Blacklist f?r FIS Meldungen schon offen
 On Error Resume Next
 Set QWB = Workbooks(sMappe)
 On Error GoTo 0
 If Not QWB Is Nothing Then                                  'Abfrage ob Blacklist ge?ffnet ist
' Mappe offen
    If MsgBox(sMappe & " schließen?", vbYesNo) <> vbYes Then
       GoTo ende       'Ende der Auswahlbox
 Else
   
' Mappe nicht offen
    Set QWB = Workbooks.Open(SMPfad)
    If QWB Is Nothing Then GoTo ende
 End If
  
Kopieren:
' 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
  
  
ende:
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = oldCalculation
 End With
  
End Sub

viele Grüße

Karl-Heinz