' --------------------------------------------------------- 
' Funktion:  SaveAsName_Date_Time 
' Eingestellt von: Andre Schau 
' Datum:     5. Julei 2012 
' Kommentar: 
' Parameter: optional Dateiname strFile, Pfad strPath, 
'            und mit Datum und Zeit boDT 
' zusaetzlich benoetigte Funktionen: 
'            CheckPath, CheckFileName 
' Hinweis:   zusätzlich benoetigte Funktionen koennen 
'            durch Codeaenderung entfallen 
' Rückgabe:  Erfolg: "", ansonsten Fehlermeldung 
' Aufruf: 
Sub SaveWithNameDate()
  Dim errMsg$
  errMsg = SaveAsName_Date_Time
  If errMsg <> "" Then MsgBox errMsg
End Sub
 Private Function SaveAsName_Date_Time( _
         Optional ByVal strPath As String, _
         Optional ByVal strFile As String, _
         Optional boDT As Boolean = True) As String
 'Speichert diese Datei mit Name und Zeit 
 'benötigte Funktion: CheckFileName, ggf. CheckPath einbauen 
 SaveAsName_Date_Time = ""
 'Variablendeklarationen 
 'String 
 Dim strDate$, strTime$, strFullName$, strExt$
 '_Datum 
 strDate = Format(Date, "_yyyymmdd")
 '_Zeit 
 strTime = Format(Now, "_hhmmss")
 'Wenn Parameter strPfad leer, dann 
 If strPath = "" Then
   'strPfad gleich Pfad von diesem Workbook setzen 
   strPath = ThisWorkbook.Path
 'Oder Wenn Parameter strPfad nicht leer, dann 
 'Hinweis: Fehlt die Funktion CheckPath, dann 
 'den Else-Zweig entfernen 
 Else
   'Zeichen prüfen - nur bei Parameter notwendig 
   strCheck = CheckPath(strPath, 1)
   'Wenn strCheck nicht leer, dann 
   If strCheck <> "" Then
     'Rueckgabewert gleich strCheck setzen 
     SaveAsName_Date_Time = strCheck
     'Funktion verlassen 
     Exit Function
   'Ende Wenn strCheck nicht leer, dann 
   End If
 'Ende Wenn Parameter strPfad leer, dann 
 End If
 'Wenn Parameter strFile leer, dann 
 If strFile = "" Then
   'strFile gleich name von diesem Workbook setzen 
   strFile = ThisWorkbook.Name
 'Oder Wenn Parameter strFile nicht leer, dann 
 'Hinweis: Fehlt die Funktion CheckFileName, dann 
 'den Else-Zweig entfernen 
 Else
   'Zeichen prüfen - nur bei Parameter notwendig 
   strCheck = CheckFileName(strFile, 1)
   'Wenn strCheck nicht leer, dann 
   If strCheck <> "" Then
     'Rueckgabewert gleich strCheck setzen 
     SaveAsName_Date_Time = strCheck
     'Funktion verlassen 
     Exit Function
   'Ende Wenn strCheck nicht leer, dann 
   End If
 End If
 'Dateiextension an letztem Punkt im Namen abtrennen 
 strExt = Split(strFile, ".")(Ubound(Split(strFile, ".")))
 'ggf. \ rechts ergänzen 
 If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
 'strFullName gleich Pfad + Dateiname ohne Erweiterung + Datum setzen 
 strFullName = strPath & Left(strFile, Len(strFile) - Len(strExt) - 1) & strDate
 'Wenn Datum und Zeit = True, dann strFullName mit Zeit ergaenzen 
 If boDT Then strFullName = strFullName & strTime
 'Fileextension je nach Version xls oder xlsx 
 'manuell setzen oder code erweitern - 
 'automatisch mit Versionspruefung 
 strFullName = strFullName & "." & strExt
 'Bei Fehler zur Fehlerbehandlung gehen 
 On Error GoTo errorhandler
 'Datei strFile unter strFullName speichern 
 Workbooks(strFile).SaveAs Filename:=strFullName
 'Funktion verlassen 
 Exit Function
'Fehlerbehandlung 
errorhandler:
'Rueckgabewert gleich Fehlernummer und Fehlerbeschreibung 
   SaveAsName_Date_Time = Err.Number & " " & Err.Description
 End Function