Hallo Volti

Ich habe den Code etwas angepasst, weil die Abläufe bei geöffneter Mappe nicht so war wie ich es brauchte.

Der Code läuft bei geöffneter Blacklist jetzt einwandfrei. Sogar besser als vorher.

Aber:

Wenn die Blacklist nicht geöffnet ist bekomme ich bei der Zeile:

If Not Workbooks("Blacklist Test") Is Nothing Then

den gleichen Laufzeitfehler 9 Index außerhalb des gültigen Bereich wie zuvor.

Ich möchte die Blacklist aber nicht ständig geöffnet haben um sie dan zu schließen.

Ich möchte die 3 Möglichkeiten durchgehen.

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

Kopieren= Alle sheets aus Blacklist bei aktiven Workbook hinter Original einfügen

Anbei mein geänderter Code, der aber nur die Sprungziele geändert hat.

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  'Abfrage ob Blacklist ge?ffnet ist
    Set QWB = Workbooks("Blacklist Test")           'Ja, Blacklist ist ge?ffnet
    If MsgBox("Blacklist Test schlie?en?", vbYesNo) = vbYes Then 'Auswahlbox ?ffnen
        QWB.Close False        ' Schlie?en der Suchmeldungen
        GoTo Kopieren
    End If
     GoTo ende       'Ende der Auswahlbox
   Else
  
' Nicht offen
    Set QWB = Workbooks.Open(SMPfad)
    If Workbooks("Blacklist Test") Is Nothing Then GoTo Fehler
 End If
 
Kopieren:
' ?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
 
 
ende:
 With Application
    .ScreenUpdating = True
    .EnableEvents = True
    .Calculation = oldCalculation
 End With
 
End Sub

Ich hoffe du bekommst den F9 Fehler noch raus

VG

Bernd