creare macro per dividere elenco in piu fogli con template

Question

Buon giorno a tutti ho un problema

vorrei creare una macro che mi divida un elenco di 7000 righe in piu fogli divisi per un valore della colonna a

il problema e che per ogni foglio deve contenere un template come si puo vedere nel file

http://wikisend.com/download/530026/esempio.xlsx

e i valori copiati devono essere "pastati" nel range dalla cellula B17:I17 in giu

e possibile fare questo?

grazie mille

Answer 1

Prova così:

---

Sub CreaFogli2()

    Dim wb As Workbook

    Dim shA As Worksheet

    Dim shB As Worksheet

    Dim shC As Worksheet

    Dim rng As Range

    Dim oRange As Range

    Dim vCol As Variant

    Dim colAccount As Collection

    Dim lRiga As Long

    Dim lRigaF As Long

    If ThisWorkbook.Path = vbNullString Then

        MsgBox "Devi prima salvare la cartella corrente"

        Exit Sub

    End If

    With Application

        .ScreenUpdating = False

        .DisplayAlerts = False

    End With

    With ThisWorkbook

        Set shA = .Worksheets("Sheet4")

        Set shB = .Worksheets("640300")

    End With

    Set wb = Application.Workbooks.Add

    Set colAccount = New Collection

    With shA

        lRiga = .Cells(.Rows.Count, 1).End(xlUp).Row

        .Range("A1:A" & lRiga).AdvancedFilter _

            Action:=xlFilterInPlace, Unique:=True

        Set rng = .Range("A2:A" & lRiga).SpecialCells(xlCellTypeVisible)

        On Error Resume Next

        For Each oRange In rng

            colAccount.Add Item:=oRange.Value, Key:=CStr(oRange.Value)

            DoEvents

        Next oRange

        On Error GoTo 0

        .ShowAllData

        For Each vCol In colAccount

            .Range("A1").AutoFilter Field:=1, Criteria1:=vCol

            lRigaF = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

            shB.Copy Before:=wb.Worksheets("Foglio1")

            Set shC = wb.Worksheets("640300")

            shC.Name = vCol

            With shC

                If lRigaF > 1 Then

                    .Range("B17:B" & (15 + lRigaF)).EntireRow.Insert

                End If

            End With

            .Range("B2:G" & lRiga).SpecialCells(xlCellTypeVisible).Copy

            shC.Range("B17").PasteSpecial Paste:=xlPasteValues

        Next vCol

        With wb

            .Worksheets(Array("Foglio1", "Foglio2", "Foglio3")).Delete

            .SaveAs Filename:=ThisWorkbook.Path & "\Export"

            .Close

        End With

        .AutoFilterMode = False

    End With

    With Application

        .CutCopyMode = False

        .ScreenUpdating = True

        .DisplayAlerts = True

    End With

    Set rng = Nothing

    Set shA = Nothing

    Set shB = Nothing

    Set shC = Nothing

    Set wb = Nothing

End Sub

---

David

Answer 2

Ciao peppecj,

vediamo se ho capito correttamente. Tu vuoi raggruppare i dati presenti nel foglio "Sheet4" in base al codice Account in colonna A e copiare i dati così filtrati nella struttura presente nel foglio "640300", un foglio per ciascun raggruppamento di dati.

Corretto?

La prima cosa che mi viene da notare è che i dati riportati nel foglio "Sheet4" non corrispondono con le colonne della struttura del foglio "640300", nè per numero 7 contro 9, nè per natura.

Esempio:

la terza colonna della struttura contenuta in nel foglio "640300" si riferisce a "Transaction Date" mentre la terza colonna contenuta nel foglio "Sheet4" fa riferimento alla descrizione "Document Type".

Cosa non sto capendo?

David

Answer 3

grazie mille

per il collegamento esterno non interessa

Grazie mille!!!

funziona perfettamente sei fantastico

ho una ultima domanda ne approfitto della tua gentilezza

me li divide intanti fogli per quanti sono i conti

e se volessi che me li divide in tanti fogli ma in un unico worksheet?

mi copia pure il numero di conto non si puo evitare che lo faccia?

Scusa ma se esce bene non solo mi rimane il lavoro mi danno pure la promozione

Answer 4

Ciao peppecj,

un modo potrebbe essere il seguente. I nuovi fogli che vengono creati vengono salvati nella cartella del file di partenza.

Ho ancora due osservazioni da fare:

• nella cartella che hai condiviso ho contato la presenza di 23.328 stili di cella. Ne avevamo già parlato qui http://answers.microsoft.com/it-it/office/forum/office_2010-excel/copia-dati-da-una-tabella/983c2295-82e6-46d0-ac45-96cbe793af70?page=2. Il nuovo formato file introdotto con Excel 2007 gestisce fino a 64.000 formati univoci di cella mentre il precedente formato arriva a 4.000. Potresti quindi avere qualche problema se decidessi di salvare in formato Excel 97-2003.
• Nella tua struttura esiste un collegamento esterno ad un'altra cartella di lavoro. Vuoi conservarlo oppure vuoi interromperlo?

---

Sub CreaFogli()

    Dim shA As Worksheet

    Dim shB As Worksheet

    Dim shC As Worksheet

    Dim rng As Range

    Dim oRange As Range

    Dim vCol As Variant

    Dim colAccount As Collection

    Dim lRiga As Long

    Dim lRigaF As Long

    If ThisWorkbook.Path = vbNullString Then

        MsgBox "Devi prima salvare la cartella corrente"

        Exit Sub

    End If

    With Application

        .ScreenUpdating = False

        .DisplayAlerts = False

    End With

    With ThisWorkbook

        Set shA = .Worksheets("Sheet4")

        Set shB = .Worksheets("640300")

    End With

    Set colAccount = New Collection

    With shA

        lRiga = .Cells(.Rows.Count, 1).End(xlUp).Row

        .Range("A1:A" & lRiga).AdvancedFilter _

            Action:=xlFilterInPlace, Unique:=True

        Set rng = .Range("A2:A" & lRiga).SpecialCells(xlCellTypeVisible)

        On Error Resume Next

        For Each oRange In rng

            colAccount.Add Item:=oRange.Value, Key:=CStr(oRange.Value)

            DoEvents

        Next oRange

        On Error GoTo 0

        .ShowAllData

        For Each vCol In colAccount

            .Range("A1").AutoFilter Field:=1, Criteria1:=vCol

            lRigaF = .AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1

            shB.Copy

            Set shC = ActiveSheet

            With shC

                If lRigaF > 1 Then

                    .Range("B17:B" & (15 + lRigaF)).EntireRow.Insert

                End If

            End With

            .Range("A2:G" & lRiga).SpecialCells(xlCellTypeVisible).Copy

            shC.Range("B17").PasteSpecial Paste:=xlPasteValues

            With ActiveWorkbook

                .SaveAs Filename:=ThisWorkbook.Path & "" & vCol

                .Close

            End With

        Next vCol

        .AutoFilterMode = False

    End With

    With Application

        .CutCopyMode = False

        .ScreenUpdating = True

        .DisplayAlerts = True

    End With

    Set rng = Nothing

    Set shA = Nothing

    Set shB = Nothing

    Set shC = Nothing

End Sub

---

David

Answer 5

Ciao!grazie per il tuo interessamento alla mia domanda adesso provo a darti piu dettagli

 

Ciao peppecj,

vediamo se ho capito correttamente. Tu vuoi raggruppare i dati presenti nel foglio "Sheet4" in base al codice Account in colonna A e copiare i dati così filtrati nella struttura presente nel foglio "640300", un foglio per ciascun raggruppamento di dati.

Corretto?

 

• si si corretto

 

La prima cosa che mi viene da notare è che i dati riportati nel foglio "Sheet4" non corrispondono con le colonne della struttura del foglio "640300", nè per numero 7 contro 9, nè per natura.

Esempio:

la terza colonna della struttura contenuta in nel foglio "640300" si riferisce a "Transaction Date" mentre la terza colonna contenuta nel foglio "Sheet4" fa riferimento alla descrizione "Document Type".

Cosa non sto capendo?

 

 

• che non ho sistemato come dovrebbe essere la struttura dell elenco li devo sistemare manualmente prima mentre per le colonne 8 e 9 devono rimanere vuote per aggiungere vari commenti se ce ne sono

si puo fare? grazie mille di tutto