Hallo Bernd,
ich kann Dir leider nicht folgen, hast Du da was verdreht:
1. Blacklist geöffnet, Abfrage ob schließen, Ja, ohne speichern schließen, weiter mit Kopieren. Funktioniert
Das kann nicht funktionieren, wenn die Blacklist geschlossen ist, kann man daraus nicht kopieren
2.Blacklist geöffnet, Abfrage ob schließen, Nein, goto Ende, Funktioniert
Wenn die Blacklist geöffnet ist, soll ohne weitere Aktion das Makro beendet werden und nichts kopiert werden?
3 Blacklist ist nicht geöffnet, weiter mit Kopieren Funktioniert nicht
Das kann auch nicht funktionieren, wenn die Blacklist geschlossen ist, kann man daraus nicht kopieren
Hier jetzt ohne Error 9:
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
SMPfad = "C:\Users\voltm\Desktop\" & 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
If MsgBox(sMappe & " 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 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
|