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
|