Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Dim Pth As String, Fll As String Application.EnableEvents = False Pth = Application.InputBox("Inserire la directory") Fll = Pth & Cells(1, 1) & "-" & Day(Cells(1, 2)) & "-" & Month(Cells(1, 2)) & "-" & Year(Cells(1, 2)) & ".xlsm" Application.DisplayAlerts = False ChDir Pth ActiveWorkbook.SaveAs Filename:=Fll Application.EnableEvents = True Application.DisplayAlerts = True End Sub
Sub SaveSheet_As() Dim NewName As Variant Nome = Range("A1") & " " & Range("B1") & ".xlsx" NewName = Application.GetSaveAsFilename( _ InitialFileName:=ActiveWorkbook.Path & "\" & _ Nome, FileFilter:="Excel Workbooks (*.xlsx), *.xlsx") If NewName=False Then Exit Sub ActiveSheet.Copy ActiveWorkbook.SaveAs Filename:=NewName, FileFormat:=xlOpenXMLWorkbook ActiveWorkbook.Close End Sub