Scrivo questo topic per condividere con gli utenti una macro che ho creato e ovviamente accettare consigli per migliorarla.
Ho creato un foglio di lavoro per fare le fatture della mia azienda,registrare i clienti e archiviare i dati sia su un'altro foglio di lavoro, sia salvare la fattura vera e propria in formato pdf.
Ho voluto svolgere tutte queste funzioni creando una unica macro.
Archiviare i dati della fattura su un foglio di lavoro dedicato è stato abbastanza semplice, sfruttando la registrazione macro.
Il problema per me è stato quello di salvare il foglio di lavoro in pdf, in quanto desideravo che il nome del file fosse ricavato automaticamente dai valori delle celle della fattura concatenandoli, e la cartella di destinazione fosse ricavata da una cella contenente la data della fattura. Inoltre, se la cartella non esite, crearla.
Leggendo vari post, ho provato e riprovato, finchè ho ottenuto il risultato tanto desiderato!
Vi allego la macro!
- Codice: Seleziona tutto
Option Explicit
Sub Salvapdf()
Dim Ws1 As Worksheet: Set Ws1 = ThisWorkbook.Worksheets("Fattura")
Dim Percorso As String, nomefile As String, Verifica
Percorso = Ws1.Range("M5") ' in questa cella ho scritto il percorso concatenando il testo del percorso con la cella variabile
Application.ScreenUpdating = False
'Application.DisplayAlerts = False
Ws1.Select
nomefile = Sheets("Fattura").Range("M3") ' in questa cella ho scritto il nome del file concatenando le celle con i valori desiderati
Set Verifica = CreateObject("Scripting.FileSystemObject")
If Not Verifica.FolderExists(Percorso) Then
Verifica.CreateFolder (Percorso)
Percorso = Percorso & nomefile & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Percorso _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
Else
Percorso = Percorso & nomefile & ".pdf"
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Percorso _
, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
:=False, OpenAfterPublish:=False
End If
'Application.DisplayAlerts = True
Application.ScreenUpdating = True
Set Ws1 = Nothing
End Sub
Buona domenica a tutti!