Sub Speichern()
MsgBox "Datei unter folgendem Pfad gespeichert: M:\Ver", vbOKOnly, "Erfolgreich"
Dim alteMappe As String
Dim neueMappe As String
alteMappe = ThisWorkbook.Name
Workbooks.Add
ActiveWorkbook.SaveAs Filename:="M:\Ver\" & Workbooks(alteMappe).Worksheets(1).Range("B4") & Workbooks(alteMappe).Worksheets(1).Range("A2") & Format(Date$, "mm.dd.yy") & ".xlsx"
neueMappe = ActiveWorkbook.Name
Workbooks(alteMappe).Worksheets(1).Range("A1:D25").Copy
Workbooks(neueMappe).Worksheets(1).Range("A1:D25").PasteSpecial Paste:=xlPasteAll
Application.CutCopyMode = False
Workbooks(alteMappe).Close savechanges:=False
Workbooks(neueMappe).Save
End Sub