Automatisch gespeicherte Mappen
30.05.2021 12:45:08
Marc
über das Öffnen von Mappen ohne Ausführen der Sub Workbook_Open hatte ich bereits einen anderen Beitrag.
Ich nutze jetzt GetObject mit vorstehendem Application.EnableEvents = False.
Das Programm soll dazu dienen, ältere Arbeitsmappen auf den neuesten Stand des Layouts und der Porgrammierung zu bringen.
Wenn ich aber jetzt eine der neu erstellten Dateien öffne, wird die Mappe nicht im Excelfenster angezeigt, das Workbook_Open jedoch ausgeführt, mit Fehler, da ja nichts angezeigt wird, selbst nicht nach einem Neustart des PCs.
Ich habe mehrere Anpassungen des Codes durchprobiert, der jetzige ist mein letzte Version.
Weiß jemand, was ich falsch mache?
Unten der betreffende Code.
Vielen Dank für Eure Hilfe.
For i = 3 To .Cells(.Rows.Count, 2).End(xlUp).Row
' Datei und Vorlage oeffnen un entsperren
Application.Goto Reference:=.Cells(i, 1), scroll:=True
On Error GoTo FehlerNeu1
Application.EnableEvents = False
Set wbNeu = GetObject(Parameter.Range("B5") & Parameter.Range("B4") & Parameter.Range("B3"))
Application.EnableEvents = True
.Cells(i, 4) = "OK"
On Error GoTo FehlerQuelle1
Application.EnableEvents = False
Set wbQuelle = GetObject(Parameter.Range("B7") & .Cells(i, 2))
Application.EnableEvents = True
.Cells(i, 5) = "OK"
On Error GoTo 0
wbNeu.Unprotect (strPW)
wbQuelle.Unprotect (strPW)
' Zelleninhalte uebertragen
On Error GoTo FehlerDaten
.Cells(i, 6) = "OK"
' Neu Datei speichern. Alle schliessen
wbQuelle.Close (False)
On Error GoTo FehlerQuelle2
wbNeu.Protect (strPW)
wbNeu.Sheets("Vertragsmatrix").Visible = True
wbNeu.SaveAs (Parameter.Range("B6") & .Cells(i, 2))
wbNeu.Close
.Cells(i, 7) = "OK"
Set wbNeu = Nothing
Set wbQuelle = Nothing
.Cells(i, 8) = "OK"
Weiter:
Next i
Application.Goto Reference:=.Range("A3"), scroll:=True
End With
Exit Sub
' Fehlerbehandlung
FehlerNeu1:
Arbeit.Cells(i, 4) = "NOK": Arbeit.Cells(i, 8) = "NOK"
MsgBox "Die Vorlage kann nicht geöffnet werden" & vbCrLf & "Benachrichtigen Sie bitte den Programmierer" & vbCrLf & _
"Programm kann nicht ausgeführt werden.", vbCritical, "Schwerwiegender Fehler"
GoTo Ende
FehlerQuelle1:
Arbeit.Cells(i, 5) = "NOK": Arbeit.Cells(i, 8) = "NOK"
If MsgBox("Die Ursprungsdatei """ & Arbeit.Cells(i, 2) & vbCrLf & """ kann nicht geöffnet werden." & vbCrLf & "NÄCHSTE?", vbCritical + vbYesNo + vbDefaultButton2, "Nächste Datei") = vbYes Then
Application.EnableEvents = True
GoTo Weiter
Else
GoTo Ende
End If
FehlerDaten:
Arbeit.Cells(i, 6) = "NOK": Arbeit.Cells(i, 8) = "NOK"
If MsgBox("Die Daten von """ & Arbeit.Cells(i, 2) & vbCrLf & """ konnten nicht in die neue Maske eingefügt werden." & vbCrLf & "NÄCHSTE?", vbCritical + vbYesNo + vbDefaultButton2, "Nächste Datei") = vbYes Then
GoTo Weiter
Else
GoTo Ende
End If
FehlerQuelle2:
Arbeit.Cells(i, 7) = "NOK": Arbeit.Cells(i, 7) = "NOK"
If MsgBox("Die neu angelegte Datei aus """ & Arbeit.Cells(i, 2) & vbCrLf & """ konnte nicht gespeichert werden." & vbCrLf & "NÄCHSTE?", vbCritical + vbYesNo + vbDefaultButton2, "Nächste Datei") = vbYes Then
GoTo Weiter
Else
GoTo Ende
End If
Ende:
On Error Resume Next
wbNeu.Close (False)
wbQuelle.Close (False)
Set wbNeu = Nothing
Set wbQuelle = Nothing
Application.EnableEvents = True
End Sub