macro salva foglio excel 2016

'Option Explicit

 'per salvare automaticamente il foglio in determinata cartella

Sub CopiaESalvaInPathX()
 
   'dichiarazioni delle variabili

   Dim wbOri As Workbook
   Dim wsOri As Worksheet
   Dim wbDest As Workbook
   Dim wsDest As Worksheet
   Dim Sh As Worksheet
   Dim sPath As String
   Dim sWS As String
   Dim sWB As String
   Dim sData As String
   Dim sNomeFile As String
   Dim nSfx As Long
   Dim nFogliNew As Long
   Dim oShp As Shape
   On Error GoTo gest_err
 
   'impostazioni applicazione
 
   With Application
     .DisplayAlerts = False
     .ScreenUpdating = False
     nFogliNew = .SheetsInNewWorkbook
     .SheetsInNewWorkbook = 1
       '.EnableEvents = False '<------------- aggiunto
   End With
 
   'set degli oggetti
   Set wbOri = ThisWorkbook
   Set wsOri = wbOri.ActiveSheet
   Set wbDest = Application.Workbooks.Add
    
   sWS = wsOri.Name
   
   sPath = "C:\Users\massimo\Desktop\salvati"
    'sPath = "C:\WINDOWS\Desktop\prova" 'indirizzo salvataggio
    
      sData = Format(Date, "dd.mm.yyyy")
   sWB = "salvata il - " & sData 'nuovo nome del foglio
 
   wsOri.Copy before:=wbDest.Sheets(1)
   Set wsDest = wbDest.ActiveSheet
   
   wsDest.Unprotect "123456"
   
   With wsDest.Cells
 
     .Interior.ColorIndex = xlNone
 
     .Copy
 
     .PasteSpecial Paste:=xlPasteValues
 
    End With
    
     wsDest.Cells.Interior.ColorIndex = xlNone '<<<--- aggiunto nessuna colore
     wsDest.Cells.FormatConditions.Delete '<<<--- aggiunto nessun fromattazione
     For Each oShp In wsDest.Shapes '<<<--- nessuna rettangolo
           ' If oShp.AutoShapeType = msoShapeRectangle Then
      oShp.Delete
            ' End If
   Next
   
   With wsDest.Range("A1")
     .Select
     .Value = "salvato il " & CStr(Date) ' rif. data oggi in alto
   End With
   
   'togliere il commento all'istuzione successiva se il foglio salvato deve essere protetto
   'wsDest.Protect "123456"
   
   sPath = sPath & "\" & sWS
   For Each Sh In wbDest.Sheets
     If Sh.Name <> wsDest.Name Then
       Sh.Delete
     End If
   Next
 
   'controllo/creazione dir da nome foglio
   If Dir(sPath, vbDirectory) = vbNullString Then
     MkDir (sPath)
   End If
   
   'loop per creazione nome file
   Do
     nSfx = nSfx + 1
     
     'sNomeFile = sPath & "\" & sWB & " - " & sWS & " - " & nSfx & ".xlsx" 'superiore excel 2000
    sNomeFile = sPath & "\" & sWS & " - " & sWB & " - " & nSfx & ".xlsx" 'superiore excel 2000
     
     'sNomeFile = sPath & "\" & sWB & " - " & sWS & " - " & nSfx & ".xls" 'excel 2000
     'sNomeFile = sPath & "\" & sWS & " - " & sWB & " - " & nSfx & ".xls" 'excel 2000
     
   Loop While Dir(sNomeFile) <> vbNullString
 
   'salvataggio file
   wsDest.SaveAs Filename:=sNomeFile
   
   'se si vuole chiudere il nuovo file togliere il commento alla riga sotto
   'wbDest.Close savechanges = False
 
gest_err:
   If Err.Number <> 0 Then
     MsgBox "Errore " & Err.Number & ": " & Err.Description, vbCritical, "Errore"
   End If
   
   Set wsOri = Nothing
   Set wbOri = Nothing
   Set wsDest = Nothing
   Set wbDest = Nothing
   
   With Application
     .ScreenUpdating = True
     .DisplayAlerts = True
     .SheetsInNewWorkbook = nFogliNew
     
           .EnableEvents = True  '<------------- aggiunto
     
   End With
 
 End Sub