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.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | Sub TestseparierenNeu()
Dim QWB As Workbook
Dim ZWB As Workbook
Dim SMPfad As String
Dim oldCalculation As Long
Dim lngCounter As Long
SMPfad = ( "C:\Test\Blacklist Test.xlsx" )
With Application
.ScreenUpdating = False
.EnableEvents = False
oldCalculation = .Calculation
.Calculation = xlCalculationManual
End With
ActiveSheet.Name = "Original"
Set ZWB = ActiveWorkbook
If Not Workbooks( "Blacklist Test" ) Is Nothing Then
Set QWB = Workbooks( "Blacklist Test" )
If MsgBox( "Blacklist Test schlie?en?" , vbYesNo) = vbYes Then
QWB.Close False
GoTo Kopieren
End If
GoTo ende
Else
Set QWB = Workbooks.Open(SMPfad)
If Workbooks( "Blacklist Test" ) Is Nothing Then GoTo Fehler
End If
Kopieren:
For lngCounter = 1 To QWB.Sheets.Count
QWB.Sheets(lngCounter).Copy After:=ZWB.Sheets(ZWB.Sheets.Count)
Next lngCounter
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
ende:
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = oldCalculation
End With
End Sub
|
Ich hoffe du bekommst den F9 Fehler noch raus
VG
Bernd
|