Hallo zusammen,
das Problem mit dem Absturz beim Workbook_BeforeSave ist leider schon seit längerem bekannt. Es gibt dazu diverse Hilferufe im Netz.
Wenn man die aktuelle Datei innerhalb der Workbook_BeforeSave unter einem anderen Namen abspeichert, führt Excel die Funktion zwar bis zum Ende aus (also Datei wird unter neuem Namen gespeichert) und stürzt dann aber ab.
Für dieses Problem gibt es jedoch eine Lösung.
Man speichert die Datei nicht in der Workbook_BeforeSave Prozedur, sondern ruft leicht zeitverzögert dazu eine eigene Routine auf.
@Noplies:
Die Speicher-Routine hab ich soweit wie möglich deinen Erfordernissen entsprechend geschrieben.
In beiden Makros mußt du die Konstanten unter <<< ANPASSEN >>> bis <<< ANPASSEN ENDE >>> entsprechend deinen Bedürfnissen/Gegebenheiten anpassen.
(Es sollte auch mit einer *.xlt funktionieren
)
Nun zum Code:
eigene Speicher-Routine:
Die Speicher-Routine muß in einem Modul liegen.
1) Excel-Datei öffnen, in der die Makros liegen sollen
2) VB-Editor öffnen (Alt+F11)
Links siehst Du ein Fenster mit der Überschrift Projekt-VBA-Project.
In diesem Fenster ist die Arbeitsmappe unter dem Namen VBAProject(Dateiname) zu finden.
3) VBA-Modul anlegen mit
3a) VBAProject(Dateiname) mit der Maus selektieren
3b) rechte Maustaste -> Einfügen -> Modul
in der Mitte geht das Code-Fenster Dateiname-Modul1(Code) auf
4) den gesamten nachfolgenden Code per copy und Paste in dieses Fenster hineinkopieren
Code:
Option Explicit
Private Function myBeforeSave()
-><<<<<<<<< A N P A S S E N >>>>>>>>>>>>>
Const c_RANGE_ZELLEMITDATEINAME = G17
Const c_DEFAULT_PFAD = d:\Ordner\Test
Const c_DEFAULT_DATEINAME = Rechnung
Const c_DEFAULT_DATEINAME_ERWEITERUNG = .xls
Const c_MITABFRAGE_DATEI_UEBERSCHREIBEN As Boolean = True
-><<<<<< A N P A S S E N E N D E >>>>>>
Dim ws As Worksheet, wb As Workbook
Dim s_Dateiname As String, s_Dateiname_Full As String, s_Pfad As String
Dim s_InhaltZelle As String, s As String, x As Long, ret As Integer
Set wb = ActiveWorkbook
Set ws = ActiveSheet
->*** aktives Blatt ist Arbeisblatt?
->nein -> SpeichernUnter abbrechen
If ws.Type <> xlWorksheet Then
MsgBox ( _
Datei kann nicht gespeichert werden. & vbLf & _
Grund: aktives Blatt ist kein Arbeitsblatt.)
GoTo AUFRAEUMEN
End If
->*** Zelle für Dateinamen prüfen
->leer -> Speichern abbrechen
->ungeeignet -> Speichern abbrechen
s_InhaltZelle = ws.Range(c_RANGE_ZELLEMITDATEINAME).Value
If s_InhaltZelle = Then
MsgBox ( _
Datei kann nicht gespeichert werden. & vbLf & _
Grund: keine Rechnungsnummer in Zelle & c_RANGE_ZELLEMITDATEINAME)
GoTo AUFRAEUMEN
End If
->*** Zellinhalt für Dateinamen prüfen
->(es werden momentan nur Zahlen und Buchstaben zugelassen,
-> ggf. muß hier erweitert werden.)
For x = 1 To Len(s_InhaltZelle)
s = Mid(s_InhaltZelle, x, 1)
Select Case s
Case 0 To 9, a To z, A To Z, ä, Ä, ö, Ö, ü, Ü, ß
Case Else
MsgBox ( _
Kundennr.-> & s_InhaltZelle &-> unzulässig. & vbLf & _
Grund: Zeichen & x & -> & s &-> wird von der Zulässigkeitsprüfung abgewiesen.)
GoTo AUFRAEUMEN
End Select
Next
->*** Vollen Dateinamen zusammensetzen
s_Dateiname = c_DEFAULT_DATEINAME & s_InhaltZelle & c_DEFAULT_DATEINAME_ERWEITERUNG
->*** Pfad prüfen
s_Pfad = c_DEFAULT_PFAD
If Len(s_Pfad) < 4 Then
MsgBox ( _
Default-Pfad-> & s_Pfad &-> unzulässig. & vbLf & _
Grund: Pfadlänge < 4)
GoTo AUFRAEUMEN
End If
If Right(s_Pfad, 1) = \ Then s_Pfad = Left(s_Pfad, Len(s_Pfad) - 1)
->Pfad nicht vorhanden ?
If Dir(s_Pfad, vbDirectory) = Then
MsgBox ( _
Default-Pfad-> & s_Pfad &-> nicht vorhanden. & vbLf & _
Bitte anlegen.)
GoTo AUFRAEUMEN
End If
->*** vollen Dateinamen zusammensetzen
s_Dateiname_Full = s_Pfad & \ & s_Dateiname
->*** Datei schon vorhanden ?
If Dir(s_Dateiname_Full, vbNormal) <> Then
If c_MITABFRAGE_DATEI_UEBERSCHREIBEN Then
ret = MsgBox( _
Datei-> & s_Dateiname_Full &-> bereits vorhanden. & vbLf & _
Soll sie überschrieben werden?, _
vbCritical + vbDefaultButton2 + vbYesNo)
If ret <> vbYes Then GoTo AUFRAEUMEN
Else
MsgBox ( _
Datei-> & s_Dateiname_Full &-> bereits vorhanden.)
GoTo AUFRAEUMEN
End If
End If
->*** Datei speichern
On Error Resume Next
Application.DisplayAlerts = False
->Events abschalten, damit nicht ein erneutes Save-Ereignis ausgelöst wird
Application.EnableEvents = False
wb.SaveAs FileName:=s_Dateiname_Full
Application.EnableEvents = True
Application.DisplayAlerts = True
If Err.Number <> 0 Then
MsgBox ( _
Datei konnte nicht gespeichert werden. & vbLf & _
Grund: & vbLf & _
Err.Description)
Err.Clear
End If
On Error GoTo 0
AUFRAEUMEN:
Set ws = Nothing: Set wb = Nothing
End Function
6) die Konstanten zwischen <<< ANPASSEN >>> und <<< ANPASSEN ENDE>>>
deinen Erfordernissen anpassen
7) speichern (Strg+S)
8 ) VB-Editor schliessen (Alt+Q)
Damit ist die Speicher-Funktion schon mal im Kasten
eigene Workbook_BeforeSave-Routine:
Jetzt kommt die Workbook_BeforeSave an die Reihe. Da die gleich wirksam wird, wenn sie in der Code-Seite der Arbeitsmappe liegt, un sie somit das normale Speichern verhindern würde, bediene ich mich eines kleinen Tricks.
In der Routine wird das Vorhandensein einer bestimmten Datei abgefragt. Ist diese vorhanden, wird ganz normal gespeichert. Die Datei wird dem Makro in der Konstanten c_DATEINAME_FULL_UMDIESENMAKROZUSPEICHERN bekanntgegeben.
Ich habe den Namen MakroBeforSaveDisable.xls im Pfad d:\Ordner\Test gewählt. Das kannst Du entsprechend deinen Gegebenheiten anpassen.
Also:
1) Excel-Datei MakroBeforSaveDisable.xls anlegen
2) Excel-Datei öffnen, in der die Makros liegen sollen
3) VB-Editor öffnen (Alt+F11)
Links siehst Du ein Fenster mit der Überschrift Projekt-VBA-Project.
In diesem Fenster ist die Arbeitsmappe unter dem Namen VBAProject(Dateiname) zu finden.
3) Doppelklick auf->DieseArbeitsmappe'
in der Mitte geht das Code-Fenster Dateiname-DieseArbeitsmappe(Code) auf
4) den gesamten nachfolgenden Code per copy und Paste in dieses Fenster hineinkopieren
Code:
Option Explicit
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
-><<<<<<<<< A N P A S S E N >>>>>>>>>>>>>
Const c_SPEICHERNUNTER_ZULASSEN As Boolean = True
Const c_DATEINAME_FULL_UMDIESENMAKROZUSPEICHERN = d:\Ordner\Test\MakroBeforSaveDisable.xls
-><<<<<< A N P A S S E N E N D E >>>>>>
->Makro ausser Kraft gesetzt ?
If Dir(c_DATEINAME_FULL_UMDIESENMAKROZUSPEICHERN, vbNormal) <> Then Exit Sub
->*** Aufruf über SpeichernUnter-Dialog ?
->ja -> Speicherung zulassen, wenn parametriert
If SaveAsUI And c_SPEICHERNUNTER_ZULASSEN Then Exit Sub
->*** Kennung Speichern zulassen löschen
Cancel = False
->Makro mit kurzer Zeitverzögerung aufrufen
Application.OnTime Now() + TimeValue(00:00:1), myBeforeSave
End Sub
6) die Konstanten zwischen <<< ANPASSEN >>> und <<< ANPASSEN ENDE>>>
deinen Erfordernissen anpassen
besonders c_DATEINAME_FULL_UMDIESENMAKROZUSPEICHERN muß passen !!!
7) speichern (Strg+S)
8 ) VB-Editor schliessen (Alt+Q)
9) Im Explorer die Datei MakroBeforSaveDisable.xls umbenennen
z.B. in MakroBeforSaveDisablexxx.xls
Jetzt sind die Makros in deiner Vorlage
gespeichert und
scharf.
Wenn Du noch Änderungen vornehmen mußt:
- MakroBeforSaveDisablexxx.xls wieder in MakroBeforSaveDisable.xls umbennen,
- Änderung
- Speichern
- MakroBeforSaveDisable.xls umbenennen in MakroBeforSaveDisablexxx.xls
Gruß Matjes