Salve,
la macro allegata è un pò datata e stata creata nel 2001 con excel 2000.
Ha semepre fatto il suo lavoro anche con le versioni successive di excel.
'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
dopo il salvataggio si apre il foglio salvato "in bianco" senza colori e macro per poter essere spedito eventualmente come posta elettettronica.
Fino a excel 2010 ha sempre funzionato, ora provando con excel 2016 dopo che si visualizza il foglio salvato per poterlo spedire bisogna cliccare in alto:
file > condividi > posta ma purtroppo non capisco perchè il pulsante file risulta bloccato.
Per poter inviare questo foglio bisogna andare "fisicamente" nel foglio creato e in questo il pulsante file funziona.
Misteri.....
Allego il workbook completo?
Un saluto e grazie in anticipo.
max
____________________________
versione excel 365 ufficio
versione excel 2007 casa