Salvare un foglio di lavoro

Ultima modifica: 27-05-2016

 

Salvare un foglio di lavoro da Excel

A volte può essere necessario salvare un unico foglio di lavoro e non una intera cartella.

Se fatto dall'interfaccia di Excel sono sufficienti queste azioni:

Salvare un foglio di lavoro da VBA di excel

Esiste la possibilità di salvare un singolo foglio via macro, quindi si potrebbe creare una macro specifica che venga richiamata all'occorrenza. Il problema più grosso è trovare le giuste istruzioni, ma probabilmente è possibile affrontare la cosa con un piccolo trucchetto: il registratore di macro.

Seguendo le istruzioni appena descritte nel precedente paragrafo si otterrà un nuovo documento che conterrà solo il foglio da cui si è partiti. Se compiamo le stesse azioni col registratore di macro attivato, avremo anche delle istruzioni VBA già pronte ad essere utilizzate.

Quel che dobbiamo fare ora è solo quello di modificare la macro per renderla più fruibile. Ma andiamo in ordine. Cominciamo col vedere ciò che è stato ottenuto col registratore di macro.

In questa macro:

1
2
3
4
5
6
7
8
9
10
11
12
Sub Macro2()
'
' Macro2 Macro
'

'
    Sheets("Broccardo").Select
    Sheets("Broccardo").Copy
    ChDir "D:\esporta_fogli\fogli"
    ActiveWorkbook.SaveAs Filename:="D:\esporta_fogli\fogli\Broccardo.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
End Sub

Nella nuova cartella che contiene il foglio scelto è bene togliere eventuali pulsanti di attivazione di eventuali macro o routines per non creare confusione.

Per conoscere il nome di tali pulsanti possiamo creare una nuova macro col registratore di macro, selezionare ciascun pulsante col tasto destro del mouse ottenendo così quel che si vede nella macro sottostante.

Notiamo che i pulsanti sono identificati come "Shapes.Range(Array("Button 1"))".

1
2
3
4
5
6
7
8
9
10
11
12
Sub Macro3()
'
' Macro3 Macro
'

'
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Sheets("Broccardo").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
    Sheets("Liberali").Select
    ActiveSheet.Shapes.Range(Array("Button 1")).Select
End Sub

Conoscendo il nome generico di questi oggetti ("Shapes") possiamo ciclare su tutti gli oggetti Shapes presenti nella pagina per conoscerne il vero nome, il tipo ed altre proprietà. Nella routine finale basta cambiare il Select o le proprietà con Delete per rimuovere tali pulsanti.

Questa è una piccola routine creata appunto per ciclare su questi oggetti per conoscerne alcune delle proprietà.

1
2
3
4
5
6
Sub ElencoPulsanti()
    Dim Shp As Shape
    For Each Shp In ActiveSheet.Shapes
        MsgBox Shp.Name & vbCrLf & Shp.Type
    Next
End Sub

La routine finale per esportare un solo foglio

Ora che abbiamo tutti gli elementi possiamo assemblare la nostra routine finale. Per far sì che questa funzioni con tutte le cartelle e tutti i fogli, che cioè possiamo riutilizzare ovunque si mostri la necessità, useremo dei riferimenti automatici per referenziare tutti gli oggetti di cui abbiamo bisogno.

In questa routine facciamo questo:

Dopo di questo viene eseguito il lavoro che ci aspettiamo da questa routine: l'esportazione del foglio in altro file Excel.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
Sub EsportaFoglio()
    Dim NomeFoglio, CurFolder, DestFolder, DestFile
    Dim Shp As Shape

    NomeFoglio = ActiveSheet.Name
    CurFolder = ActiveWorkbook.Path
    DestFolder = CurFolder & "\fogli\"
    DestFile = DestFolder & NomeFoglio & ".xlsx"

    If Dir(DestFolder, vbDirectory) = "" Then
        MsgBox "Occorre creare la sottocartella fogli"
        Exit Sub
    End If
    If Dir(DestFile) <> "" Then
        'MsgBox "Esiste"
        Kill DestFile
    End If

    Application.ScreenUpdating = False
    Sheets(NomeFoglio).Select
    Sheets(NomeFoglio).Copy
    For Each Shp In ActiveSheet.Shapes
        Shp.Delete
    Next
    ActiveWorkbook.SaveAs Filename:=DestFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWindow.Close
    Application.ScreenUpdating = True

End Sub

Per esportare tutti i fogli singolarmente

Usando la stessa tecnica vista precedentemente possiamo esportare in un file Excel tutti i fogli della nostra Cartella di lavoro.

Ma per fare questo in maniera automatica e senza dover scrivere a mano i nomi dei fogli possiamo usare questa tecnica che ci permette di ciclare tra tutti i fogli della cartella attiva in maniera completamente automatica.

1
2
3
4
5
6
Sub elencoFogli()
    Dim objSheet As Worksheet
    For Each objSheet In ThisWorkbook.Worksheets
        MsgBox objSheet.Name
    Next
End Sub

Adattando questa routine alle nostre esigenze, possiamo trasformare la precedente routine per copiare un singolo foglio nella seguente che copia tutti i fogli della nostra cartella di lavoro.

In questa routine è tutto uguale fino al controllo dell'esistenza della cartella di destinazione: If Dir(DestFolder, vbDirectory) = "" Then .....

Dopo questo controllo si entra nel cuore della nostra routine.

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
Sub EsportaliTutti()
    Dim NomeFoglio, CurFolder, DestFolder, DestFile
    Dim objSheet As Worksheet, StartFoglio
    Dim Shp As Shape

    NomeFoglio = ActiveSheet.Name
    CurFolder = ActiveWorkbook.Path
    DestFolder = CurFolder & "\fogli\"
    DestFile = DestFolder & NomeFoglio & ".xlsx"

    If Dir(DestFolder, vbDirectory) = "" Then
        MsgBox "Occorre creare la sottocartella fogli"
        Exit Sub
    End If

    Application.ScreenUpdating = False
    StartFoglio = ActiveSheet.Name
    For Each objSheet In ThisWorkbook.Worksheets
        NomeFoglio = objSheet.Name
        DestFile = DestFolder & NomeFoglio & ".xlsx"
        If Dir(DestFile) <> "" Then
            Kill DestFile
        End If
        Sheets(NomeFoglio).Select
        Sheets(NomeFoglio).Copy
        For Each Shp In ActiveSheet.Shapes
            Shp.Delete
        Next
        ActiveWorkbook.SaveAs Filename:=DestFile, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
        ActiveWindow.Close
    Next
    Sheets(StartFoglio).Select
    Application.ScreenUpdating = True

End Sub