Всё нашёл. Всем спасибо за внимание ))
(Не моё!!! Автор Шпец Докапыч)
Sub SHpetsSaveList()
Application.DisplayAlerts = False
Set WorkB = ActiveWorkbook
WorkSH = ActiveSheet.Name
Set NewB = Workbooks.Add
WorkB.Sheets(WorkSH).Copy After:=NewB.Sheets(NewB.Sheets.Count)
For i = 1 To NewB.Sheets.Count - 1
NewB.Sheets(1).Delete
Next
SName = Environ("HOMEDRIVE") & Environ("HOMEPATH") & "\Рабочий Стол\" & "_" & Format(Now, "yymmdd") & "_" & WorkSH & ".xls"
NewB.SaveAs SName
NewB.Close
MsgBox SName, 64, "Шохранение завершено!"
End Sub