Ciao,
ho postato questo thread in altro forum
https://www.forumexcel.it/forum/threads/macro-salva-foglio-attivo.48534/
non avendo avuto risposta se posso farlo lo posto qui.
La macro allegata è molto vecchia, penso del 2008/2009, ma funziona:
Option Explicit
'per salvare nelle cartelle modif. 16_06_16
Sub CopiaESalvaInPathX()
'-----------------------------------------------------------------------------------------
'avviso all'avvio
Dim avviso As String
'-----------------------------------------------------------------------------------------
Application.ScreenUpdating = False
'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 sComm1, sComm2, sComm3, sComm4, sComm5, sComm6, sComm7, sComm8, sComm9, sComm10 As String
Dim sWS As String
Dim sWB As String
Dim sData As String
Dim sNomeFile, sNomeFile_2 As String
Dim nSfx As Long
Dim nFogliNew As Long
Dim oShp As Shape
Dim savechanges As Long
Dim FSO As Object
Dim CurFolder, DestFolder As String
Dim estensione, estensione_2 As String
Const xlExcel8 As Long = 56
Const xlOpenXMLWorkbook As Long = 51
'-------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------
'per visualizzare errori
'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
'-----------------------------------------------------------------------------------------
'indirizzo path di salvataggio automatico alternativo
'---------------------------------------------------------------------------------------
'indirizzo path di salvataggio automatico alternativo
'-----------------------------------------------------------------------------------------
'indirizzo path di salvataggio automatico alternativo
sComm8 = Foglio3.Range("B1").Value
sComm9 = Foglio1.Range("N2").Value
sComm10 = Foglio1.Range("M3").Value
sPath = ThisWorkbook.Path & "\" & sComm8 '1A CARTELLA
If Dir(sPath, vbDirectory) = "" Then MkDir sPath
sPath = sPath & "\" & sComm9 '2A CARTELLA
If Dir(sPath, vbDirectory) = "" Then MkDir sPath
sPath = sPath & "\" & sComm10 '3A CARTELLA
If Dir(sPath, vbDirectory) = "" Then MkDir sPath
'sPath = sPath & "\" & sComm11 '4A CARTELLA
'If Dir(sPath, vbDirectory) = "" Then MkDir sPath
'sPath = sPath & "\" & sComm102 '5A CARTELLA
'If Dir(sPath, vbDirectory) = "" Then MkDir sPath
'-----------------------------------------------------------------------------------------
'nomi celle nel nome di salvataggio
sComm1 = Foglio1.Range("N2")
sComm2 = Foglio1.Range("Q2")
sComm3 = Foglio1.Range("M3")
sComm4 = Foglio1.Range("Q3")
sComm5 = Foglio1.Range("R3")
sComm6 = Foglio1.Range("S3")
sComm7 = Foglio1.Range("T3")
sData = Format(Date, "dd-mm-yyyy")
'sWB = "commessa - " & sComm1 & " - " & sComm2 & " (" & sData & ")"
sWB = "COMM. " & sComm1 & " - " & sComm2 & " - " & sComm3 & " - " & sComm4 & " " & _
sComm5 & " - " & sComm6 & " " & sComm7 & " ( " & sData & " )"
'--------------------------------------------------------------------------------------
wsOri.Copy before:=wbDest.Sheets(1)
Set wsDest = wbDest.ActiveSheet
wsDest.Unprotect "987654"
'--------------------------------------------------------------------------------------
'eliminazioni varie nel foglio salvato
'------------------------------------------------------------------------------------------
'togliere l'istruzione successiva se il foglio salvato non deve essere protetto
'wsDest.Protect "987654"
'-------------------------------------------------------------------------------------------
'per fermarsi nella cella del foglio salvato
'-------------------------------------------------------------------------------------------
'inserisce titoli ripetuti nel nuovo foglio
'-------------------------------------------------------------------------------------------
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 progressivo
Do
nSfx = nSfx + 1
'--------------------------------------------------------------------------------------
'estensione salvataggio
'estensione = ".xls" ' oppure xlsx
estensione = ".xlsx" ' oppure xls
sNomeFile = sPath & "\" & sWB & " - " & nSfx & estensione 'con numero progressivo
'sNomeFile = sPath & "\" & sWB & estensione 'senza numero progressivo
'--------------------------------------------------------------------------------------
'loop per creazione nome file progressivo
Loop While Dir(sNomeFile) <> vbNullString
'--------------------------------------------------------------------------------------
'estensione salvataggio
If estensione = ".xls" Then
If Val(Application.Version) < 12 Then
ActiveWorkbook.SaveAs Filename:=sNomeFile
Else
ActiveWorkbook.SaveAs Filename:=sNomeFile, FileFormat:=xlExcel8
End If
Else
ActiveWorkbook.SaveAs Filename:=sNomeFile, FileFormat:=xlOpenXMLWorkbook '<<< per formato xslx
End If
'-------------------------------------------------------------------------------------------
'estensione salvataggio_pdf
avviso = MsgBox("vuoi anche salvare il foglio in PDF?", _
vbQuestion + vbYesNo + vbDefaultButton2, "AVVISO")
If avviso = vbYes Then
estensione_2 = ".pdf"
sNomeFile_2 = sPath & "\" & sWB & " - " & nSfx & estensione_2 'con numero progressivo
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=sNomeFile_2 _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False '<<< non si apre il pdf
':=False, OpenAfterPublish:=False '<<< si apre il pdf
End If
'--------------------------------------------------------------------------------------
'se si vuole chiudere il nuovo file togliere l'istruzione successiva (togliere Option Explicit)
'wbDest.Close savechanges = True
'--------------------------------------------------------------------------------------
'per visualizzare errori
'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
End With
Application.ScreenUpdating = True
End Sub
Questa macro salva il foglio dentro a 3 cartelle:
la prima con il nome inserito in foglio3 cella B1
poi un'altra cartella nome foglio1 cella N2
poi un'altra cartella nome foglio1 cella M3
e in questa si salva il foglio.
Ora la devo usare su excel365.
Qui a casa con excel2007 dopo aver cliccato SALVA compare avviso vuoi salvare in pdf dico SI , compare il foglio salvato lo chiudo e si ritorna nel workbook e questo va bene.
Con excel 365 dopo avere cliccato SALVA sparisce il workbook, resta lo sfondo grigio, cliccco pdf SI e compare il foglio salvato.
E' un pò fastidioso ma si può che resti come per excel2007 lo sfondo normale del workbook?
Spero di essermi spiegato.
Non mi lascia inserire allegati.
Grazie
g62
[Modificato da giova62 08/05/2021 12:49]