Excel Speichern

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
 Call speichern
End Sub

Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
ActiveWorkbook.SaveAs Filename:=d:\Ordner\...\Rechnung & Cells(17, 7).Value 
End Sub

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

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