Option
Explicit
Sub
speichern()
Dim
wkbName
As
String
, wkbNeu
As
String
, wksName
As
String
Dim
oFD
As
FileDialog
wkbName = ThisWorkbook.Name
wksName = ActiveSheet.Name
Workbooks.Add
wkbNeu = ActiveWorkbook.Name
Workbooks(wkbName).Sheets(wksName).Range(
"A1:D6"
).Copy
Workbooks(wkbNeu).Sheets(1).Range(
"A1"
).PasteSpecial xlPasteAll
Application.CutCopyMode =
False
Set
oFD = Application.FileDialog(msoFileDialogSaveAs)
oFD.Title =
"Bitte Speicherort und Dateiname auswählen"
oFD.ButtonName =
"Speichern"
oFD.InitialFileName = "C:\Users\"
oFD.FilterIndex = 1
If
oFD.Show <> 0
Then
Workbooks(wkbNeu).SaveAs oFD.SelectedItems(1)
Else
Exit
Sub
End
If
End
Sub