Sub Сохранение()
On Error Resume Next
' название подпапки, в которую по-умолчанию будет предложено сохранить файл
Const REPORTS_FOLDER = "C:Users\Aman\Desktop\Games"
' ?создаём папку для файла, если её ещё нет
MkDir ThisWorkbook.Path & "\" & REPORTS_FOLDER
' выбираем стартовую папку
ChDrive Left(ThisWorkbook.Path, 1): ChDir "C:\Users\Aman\Desktop\Games"

' вывод диалогового окна для запроса имени сохраняемого файла
Filename = Application.GetSaveAsFilename("PO-13-001.xlsx", "Excel (*.xlsx),", , _
"Введите имя файла для сохраняемого отчёта", "Сохранить")
' если пользователь отказался от выбора имени файла - отменяем сохранение листа в файл
If VarType(Filename) = vbBoolean Then Exit Sub

' копируем активный лист (при этом создаётся новая книга)
Err.Clear: ActiveSheet.Copy: DoEvents
If Err Then Exit Sub ' произошла какая-то ошибка при попытке копирования листа

' убеждаемся, что активной книгой является копия листа
If ActiveWorkbook.Worksheets.Count = 1 And ActiveWorkbook.Path = "" Then
' сохраняем файл под заданным именем в формате Excel 2003
ActiveWorkbook.SaveAs Filename, xlOpenXMLWorkbook

' закрываем сохранённый файл
' (удалите следующую строку, если закрывать созданный файл не требуется)
ActiveWorkbook.Close False
End If
End Sub