Creazione cartelle excel da file master

[thunderPartecipante thunder]

Ciao,

di seguito il mio quesito:

Dati:

Un file master denominato bolle. Nella colonna "A" sono indicate la tipologia di frutta (mele, pere e banane) che si possono ripetere; nelle colonne "C" e "D"  altri valori . 

Obiettivo:

Creare tante cartelle quanti sono i valori univoci della colonna "A" nominando gli stessi con la dicitura "Bolla_ & "valore univoco". In questo caso sarebbero 3 cartelle nominate rispettivamente: <em>Bolla_mele; Bolla_pere; Bolle_banane</em>

Ogni cartella excel creata dovrà riportare i valori del file master per la rispettiva frutta creando nella colonna "A" numeri progressivi (1,2,3...) ed indicare nella cella "D4" il nome della frutta in questione.

Ad esempio il file <em>Bolla_mele </em>riporterà tutti i valori presenti nel file master "bolle" che riguardano la frutta mele e riportando nella cella "D4" il valore "mele"

Allego il file di partenza "bolle" ed i risultati aspettati

 

Grazie in anticipo

Allegati:

You must be logged in to view attached files.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Non riesco ad estrarre il file nonostante 7-zip di solito riesca ad aprire i file rar, ricevo errori di decompressione. Prova ad allegare i singoli file separati.

Nel merito, hai provato a buttare giù un pezzo di codice?

[thunderPartecipante thunder]

riallego. .

per il codice onestamente non saprei da dove iniziare (ho solo le basi per adesso e mi aiuto spesso con il registratore) 

 

Allegati:

You must be logged in to view attached files.

[thunderPartecipante thunder]

ecco l'ultimo file

Allegati:

You must be logged in to view attached files.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Errori di caricamento:

1. prove.7z: Questo tipo di file non è permesso per ragioni di sicurezza.

@admin
Strano questo errore, il file zippato dovrebbe essere consentito.

[albatros54Moderatore albatros54 Karma: 89 pts]

vecchio frac wrote:Strano questo errore, il file zippato dovrebbe essere consentito

io l'ho scaricato regolarmente e aperto

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

@albatros

- prove.rar lo scarico ma il mio 7z non lo riconosce

- prove.7z il forum stesso non ne permette neanche l'upload (come ho riportato in quote)

A cosa ti riferisci tu? può ben darsi che il mio 7z sia andato a farsi una passeggiata, è quasi ora di pranzo 🙂

 

[albatros54Moderatore albatros54 Karma: 89 pts]

@ vecchio frac

-il file l'ho aperto con wrar regolarmente

- ho cambiato l'estensine in .zip del file ed è stato aperto regolarmente sempre con Winrar

-Forse è ora di cambiare  WinZip e passare a WinRar  

 

 

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[albatros54Moderatore albatros54 Karma: 89 pts]

Se ho capito il tuo problema.

inserisci il codice che ti posto in un modulo VBA è lo esegui.

Sub CreafoglidaCollezione()
    Dim Ag As New Collection
    Dim Rw As Long
    Dim LR As Long
    Dim Sh As String
    On Error Resume Next



    With Sheets("bolle")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        Set Rng = Range(.Cells(7, 1), .Cells(Rw, 1))
        For Each cel In Rng
            If cel <> "" Then
                Ag.Add Item:=cel.Value, Key:=CStr(cel.Value)
            End If
        Next


        For Each a In Ag
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = a
        Next


        For i = 7 To Rw
            If .Cells(i, 1) <> "" Then Sh = .Cells(i, 1)
            LR = Sheets(Sh).Cells(Rows.Count, 1).End(xlUp).Row + 1

            .Cells(i, 1).Resize(1, 4).Copy Sheets(Sh).Cells(LR, 1)

        Next

        For Each cl In Worksheets
            For Each a In Ag
                If cl.Name = a Then
                    cl.Activate
                    ActiveSheet.Copy
                    ActiveSheet.SaveAs Filename:=ThisWorkbook.Path & "\" & "Bolla_" & ActiveSheet.Name & ".xlsx"
                End If
            Next
        Next

    End With
End Sub

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

albatros54 wrote:Forse è ora di cambiare  WinZip e passare a WinRar

pc aziendale, non posso   

Comunque allego la mia proposta per risolvere la domanda. Lasciamo al nostro interlocutore scegliere la versione che gli piace di più 🙂

Option Explicit

Sub scan_table()
Dim cn As Object
Dim rs As Object
Dim rs2 As Object
Dim s As String
Dim wbk As Workbook
Dim iRow As Long
Dim nBolla As Long
    
Const adOpenStatic = 3
Const adLockOptimistic = 3
Const adCmdText = 1

    s = ThisWorkbook.Path & "\"
    ThisWorkbook.SaveCopyAs s & "temporary.xlsx"

    Set cn = CreateObject("ADODB.Connection")
    Set rs = CreateObject("ADODB.Recordset")
    Set rs2 = CreateObject("ADODB.Recordset")

    cn.Open "Provider=Microsoft.ACE.OLEDB.12.0;" & _
        "Data Source=" & s & "temporary.xlsx;Extended Properties=""Excel 12.0 Xml;HDR=Yes"";"
    
    rs.Open "SELECT DISTINCT Frutta FROM [Bolle$A6:D1000]", _
        cn, adOpenStatic, adLockOptimistic, adCmdText

    Do Until rs.EOF
        Set wbk = Workbooks.Add
        With wbk.Sheets(1)
            .Range("B3") = "Operatore"
            .Range("B4") = "Luigi"
            .Range("C3") = "Corriere"
            .Range("C4") = "Brt"
            .Range("D3") = "Frutta"
            .Range("D4") = rs("Frutta")
            .Range("A6") = "Bolla"
            .Range("B6") = "Lotto"
            .Range("C6") = "Peso (kg)"
            .Range("B3:D3,A6:C6").Font.Bold = True
            
            rs2.Open "SELECT Lotto, [Peso (kg)] FROM [Bolle$A6:D1000] WHERE Frutta = '" & rs(0) & "'", _
                cn, adOpenStatic, adLockOptimistic, adCmdText
            
            iRow = 7
            nBolla = 0
            Do Until rs2.EOF
                nBolla = nBolla + 1
                .Cells(iRow, "A") = nBolla
                .Cells(iRow, "B") = rs2("Lotto")
                .Cells(iRow, "C") = rs2("Peso (kg)")
                iRow = iRow + 1
                rs2.movenext
            Loop
            rs2.Close
            .SaveAs s & "Bolla_" & Replace(rs(0), " ", "-")
            wbk.Close
        End With
        
        rs.movenext
    Loop

    rs.Close
    cn.Close
    Kill s & "temporary.xlsx"
    
    MsgBox "Finito.", vbInformation
End Sub

Sarebbe interessante sapere se i numeri di bolle aumentano (quindi se si deve mantenere lo storico) o se basta che ad ogni esecuzione la macro crei un file nuovo sovrascrivendo quello vecchio. In tal modo si perdono i dati precedenti (il codice che propongo non mantiene lo storico).

@Albatros

Buona l'idea di generare prima i fogli e poi di creare il file dedicato partendo da questi.

[thunderPartecipante thunder]

Ciao grazie ad entrambi intanto per il tempo dedicatomi. Dunque:

@Albatros le cartelle vengono generate con i nomi corretti. Non mantiene però il formato di partenza, la colonna "A"deve avere poi i numeri ed  il nome della cella "C4"  che non viene compilato. Se possibile preferirei che nel file di partenza non rimanessero i fogli creati per l'export.

@vecchio frac l'output è corretto però vorrei chiederti se è possibile evitare di dover scrivere nel codice tutte le informazioni delle celle 

 With wbk.Sheets(1)
            .Range("B3") = "Operatore"
            .Range("B4") = "Luigi"
            .Range("C3") = "Corriere"
            .Range("C4") = "Brt"
            .Range("D3") = "Frutta"
            .Range("D4") = rs("Frutta")
            .Range("A6") = "Bolla"
            .Range("B6") = "Lotto"
            .Range("C6") = "Peso (kg)"
            .Range("B3:D3,A6:C6").Font.Bold = True

vorrei che prendesse tutto il contenuto dal file di partenza, format compreso,  senza doverlo specificare(esclusa la cella C4). Così nel caso cambiasse l'operatore o l'intestazione non devo modificare a mano.

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

thunder wrote:vorrei chiederti se è possibile evitare di dover scrivere nel codice tutte le informazioni delle celle 

Certamente, ho proposto un modellino basato sull'esempio, chiaro che va adattato all'esigenza specifica.

Hai scelto quale soluzione preferisci? tanto per non lavorare in due sullo stesso file (se scegli la mia proposta ti chiedo un pochino di pazienza per l'affinamento, mi ci metto appena posso). Comunque potresti anche provare da solo a metterci mano (cosa auspicabile, perchè poi dovrai riuscire a manutenere il codice correggendo gli errori)

[thunderPartecipante thunder]

Per adesso quella che sia avvicina più all'output desiderato è la tua vecchio frac. Il codice sto già provando ad inserirlo nel file originale.

 

Comunque non devi chiedere pazienza a me. Siete voi che mi state aiutando, anzi grazie!  

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

thunder wrote:

Il codice sto già provando ad inserirlo nel file originale

Ah bè, basta copiarlo in un modulo e lanciare 🙂 se la struttura dati (riferimenti di celle) è quella da te fornita come esempio tutto fila liscio.

 

edit by VF: il quote aveva dato i numeri, citando una frase sbagliata.

[thunderPartecipante thunder]

no cambia un po' la struttura se no non facevo proprio niente poi   

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

Ricordami questa discussione per terminare il lavoro, se vedi che passa tempo senza risposte mandami un promemoria.

[albatros54Moderatore albatros54 Karma: 89 pts]

Ti posto queste poche righe modificate per le tue esigenze, provalo e fai sapere,naturalmente il codice è stato scritto seguendo la struttura del file che hai postato

`Option Explicit
Sub CreafoglidaCollezione()
   Dim Ag As New Collection
    Dim Rw As Long, i As Long
    Dim LR As Long
    Dim Sh As String, cel As Variant
    Dim rng As Range, cl As Worksheet
    Dim a As Variant
    On Error Resume Next



    With Sheets("bolle")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = Range(.Cells(7, 1), .Cells(Rw, 1))
        For Each cel In rng
            If cel <> "" Then
                Ag.Add Item:=cel.Value, Key:=CStr(cel.Value)
            End If
        Next


        For Each a In Ag
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = a
        Next


        For i = 7 To Rw
            If .Cells(i, 1) <> "" Then Sh = .Cells(i, 1)
            .Cells(3, 1).Resize(4, 5).Copy Sheets(Sh).Cells(1, 1)
            LR = Sheets(Sh).Cells(Rows.Count, 1).End(xlUp).Row + 1

            .Cells(i, 1).Resize(1, 4).Copy Sheets(Sh).Cells(LR, 1)
            If LR = 5 Then
                Sheets(Sh).Cells(LR, 2) = 1
            Else
                Sheets(Sh).Cells(LR, 2) = Sheets(Sh).Cells(LR, 2).Offset(-1, 0) + 1
            End If
        Next

        For Each cl In Worksheets
            For Each a In Ag
                If cl.Name = a Then
                    cl.Activate
                    ActiveSheet.Copy
                    ActiveSheet.SaveAs Filename:=ThisWorkbook.Path & "\" & "Bolla_" & ActiveSheet.Name & ".xlsx"
                End If
            Next
        Next

    End With
    Application.DisplayAlerts = False
    With ThisWorkbook.Sheets("Bolle").Activate
        For Each a In Ag
            Worksheets(a).Delete
        Next
    End With
    Application.DisplayAlerts = True
End Sub
`

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[thunderPartecipante thunder]

Ciao! 

grazie intanto. Dunque ti riporto i feedback:

- nei file di output viene ancora riportata la colonna della frutta ma non deve esserci. 

- nei file di output viene persa la dimensione delle celle di partenza. Dovrebbero mantenere la stessa formattazione e dimensione del file master "bolle"

- la casella della variabile non viene compilata con il nome della frutta

-se non ho sbagliato ho visto come aumentare il numero delle colonne :

For i = 7 To Rw
            If .Cells(i, 1) <> "" Then Sh = .Cells(i, 1)
            .Cells(3, 1).Resize(4, 5).Copy Sheets(Sh).Cells(1, 1) '' mod 5 con la colonna di interesse'
            LR = Sheets(Sh).Cells(Rows.Count, 1).End(xlUp).Row + 1

            .Cells(i, 1).Resize(1, 4).Copy Sheets(Sh).Cells(LR, 1) ''mod 4 con la colonna di interesse'

vorrei che mantenesse anche le prime 2 righe. Dove devo modificare?

Ultima segnalazione che però non avevo specificato prima ( mea culpa). Ho un 'immagine con il logo. Se lancio il codice oltre a non mantenerne la posizione l'immagine viene copiata più volte all'interno della stessa cartella excel. 

 

Grazie

[albatros54Moderatore albatros54 Karma: 89 pts]

thunder wrote:vorrei che mantenesse anche le prime 2 righe. Dove devo modificare?

Cosa intendi?

ti posto il codice con le modifiche , provalo e fai sapere

Sub CreafoglidaCollezione()
    Dim Ag As New Collection
    Dim Rw As Long
    Dim LR As Long
    Dim Sh As String
    On Error Resume Next



    With Sheets("bolle")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        Set Rng = Range(.Cells(7, 1), .Cells(Rw, 1))
        For Each cel In Rng
            If cel <> "" Then
                Ag.Add Item:=cel.Value, Key:=CStr(cel.Value)
            End If
        Next


        For Each a In Ag
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = a
        Next


        For i = 7 To Rw
            If .Cells(i, 1) <> "" Then Sh = .Cells(i, 1)
            .Cells(3, 2).Resize(4, 5).Copy Sheets(Sh).Cells(1, 1)
            LR = Sheets(Sh).Cells(Rows.Count, 1).End(xlUp).Row + 1
            
            .Cells(i, 2).Resize(1, 3).Copy Sheets(Sh).Cells(LR, 1)
            If LR = 5 Then
           Sheets(Sh).Cells(LR, 1) = 1
            Else
            Sheets(Sh).Cells(LR, 1) = Sheets(Sh).Cells(LR, 1).Offset(-1, 0) + 1
            End If
        Next

        For Each cl In Worksheets
            For Each a In Ag
                If cl.Name = a Then
                    cl.Activate
                    Cells(2, 4) = a
                    ActiveWindow.Zoom = 70
                    ActiveSheet.Copy
                    ActiveSheet.SaveAs Filename:=ThisWorkbook.Path & "\" & "Bolla_" & ActiveSheet.Name & ".xlsx"
                End If
            Next
        Next

    End With
    Application.DisplayAlerts = False
    With ThisWorkbook.Sheets("Bolle").Activate
    For Each a In Ag
             Worksheets(a).Delete
        Next
        End With
        Application.DisplayAlerts = True
End Sub

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[thunderPartecipante thunder]

Ciao!

variabile inserita e colonna eliminata correttamente grazie!

Intendevo che le prime due righe del file iniziale dovrebbero essere mantenute. 

Ti allego il file master originale "Bolle.xlsm" con il tuo codice già inserito (ho aggiunto solo la dichiarazione delle variabili rispetto all'ultimo che mi avevi inviato e modificato il numero delle colonne) e quello che vorrei fosse il risultato aspettato (allego solo un file di esempio "Bolle_mele.xlsx"). 

Gli ultimi due problemi che rimangono sono oltre alle prime due righe da mantenere sono l'immagine(che viene copiata più volte)  e la perdita della formattazione delle celle originali

 

Grazie

 

Allegati:

You must be logged in to view attached files.

[albatros54Moderatore albatros54 Karma: 89 pts]

ho apportato alcune modifiche, che dovrebbero essere quelle che ta hai richiesto, ti allego il codice

`Option Explicit
Sub CreafoglidaCollezione()
    Dim Ag As New Collection
    Dim Rw As Long, i As Long
    Dim LR As Long
    Dim Sh As String, cel As Variant
    Dim a As Variant
    Dim rng As Range, cl As Worksheet
    On Error Resume Next



    With Sheets("bolle")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = Range(.Cells(7, 1), .Cells(Rw, 1))
        For Each cel In rng
            If cel <> "" Then
                Ag.Add Item:=cel.Value, Key:=CStr(cel.Value)
            End If
        Next


        For Each a In Ag
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = a
        Next


        For i = 7 To Rw
            If .Cells(i, 1) <> "" Then Sh = .Cells(i, 1)
            .Cells(1, 2).Resize(6, 13).Copy Sheets(Sh).Cells(1, 1)
            LR = Sheets(Sh).Cells(Rows.Count, 1).End(xlUp).Row + 1

            .Cells(i, 2).Resize(1, 13).Copy Sheets(Sh).Cells(LR, 1)
            If LR = 7 Then
                Sheets(Sh).Cells(LR, 1) = 1
            Else
                Sheets(Sh).Cells(LR, 1) = Sheets(Sh).Cells(LR, 1).Offset(-1, 0) + 1
            End If
        Next

        For Each cl In Worksheets
            For Each a In Ag
                If cl.Name = a Then
                    cl.Activate
                    Cells(4, 4) = a
                    Columns("A:A").ColumnWidth = 18.43
                    Columns("B:B").ColumnWidth = 18.43
                    Columns("C:C").ColumnWidth = 24.71
                    Columns("D:D").ColumnWidth = 36.86
                    Rows("3:3").RowHeight = 42.75
                    Rows("4:4").RowHeight = 57.75
                    ActiveWindow.Zoom = 70
                    ActiveSheet.Copy
                    ActiveSheet.SaveAs Filename:=ThisWorkbook.Path & "\" & "Bolla_" & ActiveSheet.Name & ".xlsx"
                End If
            Next
        Next

    End With
    Application.DisplayAlerts = False
    With ThisWorkbook.Sheets("bolle").Activate
        For Each a In Ag
            Worksheets(a).Delete
        Next
    End With
    Application.DisplayAlerts = True
End Sub

questo pezzo di codice formatta le colonne e le celle, lascio a te il compito di proseguire  

For Each cl In Worksheets
For Each a In Ag
If cl.Name = a Then
cl.Activate
Cells(4, 4) = a
Columns("A:A").ColumnWidth = 18.43
Columns("B:B").ColumnWidth = 18.43
Columns("C:C").ColumnWidth = 24.71
Columns("D:D").ColumnWidth = 36.86
Rows("3:3").RowHeight = 42.75
Rows("4:4").RowHeight = 57.75
ActiveWindow.Zoom = 70
ActiveSheet.Copy

 per le righe puoi fare un ciclo, dichiarando sempre le variabile , che nel codice mancano  

If cl.Name = a Then
cl.Activate
ulti = Cells(Rows.Count, 1).End(xlUp).Row
Cells(4, 4) = a
Set rfg = Range("a6:A" & ulti)
For i = 1 To rfg.Rows.Count
rfg.Rows(i).RowHeight = 24
Next

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[thunderPartecipante thunder]

Perfetto grazie!

faccio le modifiche necessarie..ti chiedo un ultimo indizio se puoi. Come posso evitare che l'immagine venga copiata più volte e non perda la posizione nei file di output? 

[vecchio fracSenior Moderator vecchio frac Karma: 272 pts]

thunder ha scritto:

Come posso evitare che l'immagine venga copiata più volte e non perda la posizione nei file di output?

Si potrebbe impostare, via codice, la proprietà "non spostare nè ridimensionare con le celle":

ActiveSheet.Shapes("immagine 3").Placement = xlFreeFloating

 

[thunderPartecipante thunder]

ma devo associare il codice all'immagine in un modulo diverso?

Ho provato ad inserire la stringa sotto le variabili (erroneamente presumo) ma nei file di output non mi copia più l'immagine

[albatros54Moderatore albatros54 Karma: 89 pts]

Ciao , sostituisci il codice con questo che ti posto e fai sapere se abbiamo concluso  

Option Explicit
Sub CreafoglidaCollezione()
    Dim Ag As New Collection
    Dim Rw As Long, i As Long, ulti As Long
    Dim LR As Long
    Dim Sh As String, cel As Variant
    Dim a As Variant
    Dim rng As Range, cl As Worksheet, wsh As Worksheet, rfg As Range
    On Error Resume Next



    With Sheets("bolle")
        Rw = .Cells(Rows.Count, 1).End(xlUp).Row
        Set rng = Range(.Cells(7, 1), .Cells(Rw, 1))
        For Each cel In rng
            If cel <> "" Then
                Ag.Add Item:=cel.Value, Key:=CStr(cel.Value)
            End If
        Next


        For Each a In Ag
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = a
        Next


        For i = 7 To Rw
            If .Cells(i, 1) <> "" Then Sh = .Cells(i, 1)
            .Cells(1, 2).Resize(6, 13).Copy Sheets(Sh).Cells(1, 1)
            LR = Sheets(Sh).Cells(Rows.Count, 1).End(xlUp).Row + 1

            .Cells(i, 2).Resize(1, 13).Copy Sheets(Sh).Cells(LR, 1)
            If LR = 7 Then
                Sheets(Sh).Cells(LR, 1) = 1
            Else
                Sheets(Sh).Cells(LR, 1) = Sheets(Sh).Cells(LR, 1).Offset(-1, 0) + 1
            End If
        Next

        For Each cl In Worksheets
            For Each a In Ag
                If cl.Name = a Then
                    cl.Activate
                    Set wsh = Application.ActiveSheet
                    With Range("G3:K4")
                        With wsh.Shapes
                            For i = .Count - 1 To 1 Step -1
                                With .Item(i)
                                    If .Type = msoPicture Then
                                        .Delete
                                    End If
                                End With
                            Next
                        End With
                    End With
                    wsh.Shapes(i).Select

                    With Selection
                        .ShapeRange.LockAspectRatio = msoFalse
                        .Left = Cells(3, 7).Left
                        .Top = Cells(3, 7).Top
                        .Width = Cells(3, 11).Width
                        .Height = Cells(4, 11).Height
                        .ShapeRange.ZOrder msoBringToFront
                        .Width = 200: .Height = 50
                    End With
                    ulti = Cells(Rows.Count, 1).End(xlUp).Row
                    Cells(4, 4) = a
                    Set rfg = Range("a1:A" & ulti)
                    For i = 1 To rfg.Rows.Count
                        rfg.Rows(i).RowHeight = 24
                    Next
                    Columns("A:A").ColumnWidth = 18.43
                    Columns("B:B").ColumnWidth = 18.43
                    Columns("C:C").ColumnWidth = 24.71
                    Columns("D:D").ColumnWidth = 36.86

                    ActiveWindow.Zoom = 70
                    ActiveSheet.Copy
                    ActiveSheet.SaveAs Filename:=ThisWorkbook.Path & "\" & "Bolla_" & ActiveSheet.Name & ".xlsx"
                End If
            Next
        Next

    End With
    Application.DisplayAlerts = False
    With ThisWorkbook.Sheets("bolle").Activate
        For Each a In Ag
            Worksheets(a).Delete
        Next
    End With
    Application.DisplayAlerts = True
End Sub

 

Qual è il punto di avere gusti diversi, se non mostrare che i cervelli lavorano diversamente, che pensiamo diversamente? ( Alan Turing)
Sempre il mare, uomo libero, amerai!
( Charles Baudelaire )

[Autore]

Articoli