Private Sub ShortcutZuweisen()
KeyBindings.Add KeyCode:=BuildKeyCode(wdKeyAlt, wdKeyS), _
KeyCategory:=wdKeyCategoryMacro, Command:="saveMarkAS"
End Sub
Sub saveMarkAS()
'
' saveAS Makro
'Makro geschrieben von Johannes Gurlitt: Makro@cognitive-tools.de, bitte diesen Hinweis stehen lassen.
'Information zu diesem Makro finden sie unter www.cognitive-tools.de unter dem Link Abspeicher-Helferlein für Word(R)
'Word, Microsoft und Windows sind eingetragene Warenzeichen der Microsoft Corporation in den USA und anderen Ländern.

    Dim dt As Date
    Dim dt1 As Date
    Dim ersteZJ As String
    Dim pfadJ As String
    Dim sname As String
    sname = "a"
    
    
    dt = Date
    'MsgBox dt
    'dt1 = Format(dt, "yy/mm/dd")
    dt1 = Str(dt)
    dayJ = Left(dt1, 2)
    'MsgBox dayJ
    monthJ = Mid(dt1, 4, 2)
    'MsgBox monthJ
    yearJ = Mid(dt1, 9, 2)
    'MsgBox yearJ
  
    'Hier den Pfad eingeben
    nameJ = ActiveDocument.Name
    pfadJ = ActiveDocument.Path
    'pfadJ = Application.DefaultFilePath
    'schauen ob bereits Datum zu Dateibeginn dazu wird geschaut of erste Ziffer eine 0
    ' pfadJ = "c:\windows\desktop\"
    ersteZJ = "_" & nameJ
    ersteZJ = Mid(ersteZJ, 2, 1)

    textAusw = Selection.Text

name03 = yearJ & monthJ & dayJ & "_" & textAusw
    'MsgBox name03
    sizeString = Len(name03)
    'MsgBox sizeString
    name03 = Trim(name03)
    'MsgBox sizeString
    
    letzteZeichen = Mid(name03, sizeString, sizeString)
    'MsgBox letzteZeichen
   ergebnisAZ = letzteZeichen Like "[A-Z]"
   ergebnisazK = letzteZeichen Like "[a-z]"
   ergebnis19 = letzteZeichen Like "#"
   
   
   'MsgBox ergebnisAZ
   'MsgBox ergebnisazK
   'MsgBox ergebnis19
   
    If ergebnisAZ Or ergebnisazK Or ergebnis19 Then
    'MsgBox "hallo"
    Else
    name03 = Mid(name03, 1, sizeString - 1)
    End If

    
If Len(textAusw) > 2 Then
        With Dialogs(wdDialogFileSaveAs)
            .Name = name03
            'MsgBox .Name
            .Show
        End With
        Else
            If ersteZJ = "0" Then
                Dialogs(wdDialogFileSaveAs).Show
                Else
                 With Dialogs(wdDialogFileSaveAs)
                   .Name = name03
                   .Show
                 End With
            End If
    End If

  End Sub