Creazione cartelle excel da file master

Stai vedendo 25 articoli - dal 1 a 25 (di 26 totali)

1 2 →

Autore

Articoli

14/11/2018 alle 9:33 #8059 Score: 0 | Risposta

thunder

Partecipante

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.

14/11/2018 alle 10:39 #8061 Score: 0 | Risposta

vecchio frac

Senior Moderator

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?

14/11/2018 alle 10:58 #8063 Score: 0 | Risposta

thunder

Partecipante

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.

14/11/2018 alle 11:00 #8067 Score: 0 | Risposta

thunder

Partecipante

ecco l'ultimo file

Allegati:

You must be logged in to view attached files.

14/11/2018 alle 11:25 #8070 Score: 0 | Risposta

vecchio frac

Senior Moderator

Karma: 272 pts

Errori di caricamento:

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

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

14/11/2018 alle 11:36 #8071 Score: 0 | Risposta

albatros54

Moderatore

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 )

14/11/2018 alle 11:52 #8074 Score: 0 | Risposta

vecchio frac

Senior Moderator

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 🙂

14/11/2018 alle 12:09 #8075 Score: 0 | Risposta

albatros54

Moderatore

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

14/11/2018 alle 14:27 #8079 Score: 0 | Risposta

albatros54

Moderatore

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

14/11/2018 alle 14:36 #8080 Score: 0 | Risposta

vecchio frac

Senior Moderator

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.

14/11/2018 alle 15:19 #8087 Score: 0 | Risposta

thunder

Partecipante

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.

14/11/2018 alle 15:54 #8090 Score: 0 | Risposta

vecchio frac

Senior Moderator

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)

14/11/2018 alle 16:15 #8092 Score: 0 | Risposta

thunder

Partecipante

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!

14/11/2018 alle 18:32 #8094 Score: 0 | Risposta

vecchio frac

Senior Moderator

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.

15/11/2018 alle 9:53 #8108 Score: 0 | Risposta

thunder

Partecipante

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

15/11/2018 alle 11:30 #8111 Score: 0 | Risposta

vecchio frac

Senior Moderator

Karma: 272 pts

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

15/11/2018 alle 11:54 #8113 Score: 0 | Risposta

albatros54

Moderatore

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
`

15/11/2018 alle 14:26 #8118 Score: 0 | Risposta

thunder

Partecipante

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

15/11/2018 alle 14:56 #8119 Score: 1 | Risposta

albatros54

Moderatore

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

16/11/2018 alle 12:34 #8159 Score: 0 | Risposta

thunder

Partecipante

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.

16/11/2018 alle 13:40 #8165 Score: 1 | Risposta

albatros54

Moderatore

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

16/11/2018 alle 14:18 #8168 Score: 0 | Risposta

thunder

Partecipante

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?

16/11/2018 alle 19:54 #8175 Score: 0 | Risposta

vecchio frac

Senior Moderator

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

17/11/2018 alle 13:18 #8187 Score: 0 | Risposta

thunder

Partecipante

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

17/11/2018 alle 14:55 #8188 Score: 1 | Risposta

albatros54

Moderatore

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

Autore

Articoli

Stai vedendo 25 articoli - dal 1 a 25 (di 26 totali)

1 2 →

Forum Excel VBA

[Risolto] Creazione cartelle excel da file master

Allegati:

Allegati:

Allegati:

Allegati: