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
|