Dateiname vor dem Speichern ändern

Computer: Software & Programmierung Office Software
1

Hallo,
ich habe ein Excel-Workbook, dass ich per Button aktualisieren kann (das Book zieht Daten aus einer Access-DB und stellt sie per diverser Pivots dar).
Um zu verhindern, dass ich einen alten Stand versehentlich überschreibe, möchte ich das Workbook, sobald es geändert wurde, unter einem neuen Dateinamen speichern. Dazu setzt das Aktualisierungsmakro das Datum im Range „Datum“ auf heute.
Nun versuche ich, dass Speichern (z.B. per STRG+S) so zu automatisieren, dass der Dateiname automatisch geändert wird in
„Daten [Quartal] [Datum].xls“.
Das Quartal errechne ich an anderer Stelle (Range „quartal“).
Ich mache nun im Event „BeforeSave“ folgendes:

Private Sub Workbook\_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim datum As String, dateiname As String, quartal As String, pfad As String
On Error Resume Next

' nicht bei SAVE AS
If SaveAsUI = False Then

 With ActiveWorkbook
 datum = Format(.Sheets(1).Range("Datum").Value, "yyyy-mm-dd")
 quartal = .Sheets(1).Range("quarter").Value
 pfad = .Path
 End With

 dateiname = pfad & "\Daten " & quartal & " " & datum & ".xls"

 Application.EnableEvents = False
 ActiveWorkbook.SaveAs dateiname
 Application.EnableEvents = True

End If
End Sub

Alles funktioniert bestens, die Datei wird umbenannt und gespeichert. Aber dann schmiert Excel (2003 [11.8142.8132] SP2) gnadenlos und reproduzierbar ab. Auch bei Kollegen ist das gleiche Verhalten zu beobachten.
Hat einer eine Idee, was Excel so verwirren kann?
Gibt es eine elegantere, robustere Art, das Thema zu lösen?
Danke für eure Hilfe.

Reiner

2

Alles funktioniert bestens, die Datei wird umbenannt und
gespeichert. Aber dann schmiert Excel (2003 [11.8142.8132]
SP2) gnadenlos und reproduzierbar ab. Auch bei Kollegen ist
das gleiche Verhalten zu beobachten.

Hi Reiner,

probiers mal so (ungetestet):

Option Explicit
'
Private Sub Workbook\_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim datum As String, dateiname As String, quartal As String, pfad As String
On Error GoTo Ende
Cancel = True
' nicht bei SAVE AS
If SaveAsUI = True Then GoTo Ende
With ActiveWorkbook
 datum = Format(.Sheets(1).Range("Datum").Value, "yyyy-mm-dd")
 quartal = .Sheets(1).Range("quarter").Value
 pfad = .Path
 dateiname = pfad & "\Daten " & quartal & " " & datum & ".xls"
 Application.EnableEvents = False
 .SaveAs dateiname
End With
Ende:
If Err.Number 0 Then MsgBox Err.Number & " " & Err.Description
Application.EnableEvents = True
End Sub

Gruß
Reinhard