macro salva foglio attivo

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

Sub copia()
Dim spath As String, snome As String
snome = "1111.xlsx"
spath = ThisWorkbook.Path
    Cells.Select
    Selection.Copy
    Workbooks.Add
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ActiveWorkbook.SaveAs Filename:=Path & snome, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
snome = "1111.Pdf"
    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=Path & snome _
    , Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas _
    :=False, OpenAfterPublish:=False
    MsgBox "fatto"
End Sub