Creare nuovi file da database excel

[walter_sign]

Buongiorno a tutti.
Ho un problema da affrontare e non sono molto bravo in vba....

Un file contiene un elenco di attività associate ad un agente a sua volta associate ad un valore.
Vorrei impostare una macro in modo che mi crei un file excel diverso per ogni agente (in colonna A) con tutte le altre informazioni delle colonne corrispondenti e lo salvi nella cartella dove è presente il file principale. Il file dovrebbe avere il nome dell'agente. Se possibile la macro dovrebbe funzionare a prescindere dall''eventuale inserimento di altre colonne dopo l'ultima.
Vi allego l'esempio.
https://dl.dropboxusercontent.com/u/708 ... a%201.xlsx

Grazie e chi mi risponderà e buone feste a tutti.
Walter

[scanacc]

Prova questa

Codice: Seleziona tutto

Public Sub m()

    'dichiaro le variabili
    Dim col As Collection
    Dim v As Variant
    Dim sh As Worksheet
    Dim lRiga As Long
    Dim lRigaTot As Long
    Dim lng As Long
    Dim sPath As String
   
    'metto un riferimento al foglio che
    'contiene la tabella (nell'esempio il Foglio1)
    Set sh = ThisWorkbook.Worksheets("Foglio1")
    'creo la Collection
    Set col = New Collection
    sPath = ThisWorkbook.Path & "\"
   
    'evito l'aggiormanto del monitor
    'che rende visibile ogni singolo passaggio
    Application.ScreenUpdating = False
   
    With sh
        'trovo l'ultima riga con un valore della
        'colonna A della tabella
        lRiga = .Range("A" & .Rows.Count).End(xlUp).Row
       
        'On Errore Resume Next evita che durante il
        'caricamento dei valori univoci nella Collection
        'venga sollevata un'eccezione (errore)
        On Error Resume Next
        'ciclo la colonna A della tabella e carico i valori
        'univoci nella Collection
        For lng = 2 To lRiga
            col.Add CStr(.Range("A" & lng).Value), _
                CStr(.Range("A" & lng).Value)
        Next
       
        'riporto a 0 la gestione degli errori
        Err.Number = 0
       
        'ciclo la Collection
        For Each v In col
            'filtro la colonna A della tabella
            'per il valore contenuto in v
            .Range("$A$1").AutoFilter Field:=1, Criteria1:=v
            'creo un nuovo foglio e lo posiziono alla fine dei
            'fogli visibili in Excel lato celle
            ThisWorkbook.Worksheets.Add After:=Sheets(Sheets.Count)
            'do al nuovo foglio il nome del valore contenuto in v
            ActiveSheet.Name = v
            'se è già presente un foglio con lo stesso nome viene
            'sollevata un'eecezione (errore) e creato un foglio
            'con un nome generico; quindi elimino il foglio vecchio
            If Err.Number <> 0 Then
                'evito la MsgBox di alert per ogni foglio eliminato
                Application.DisplayAlerts = False
                'elimino l'eventuale vecchio foglio con lo stesso nome
                ThisWorkbook.Worksheets(v).Delete
                'do al nuovo foglio  il nome del valore contenuto in v
                ActiveSheet.Name = v
                'riporto a 0 la gestione degli errori
                Err.Number = 0
                'ripristino le MsgBox di alert
                Application.DisplayAlerts = True
            End If
           
            'copio i dati della tabella filtrati
            .Range("A1").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
            'incollo sul nuovo foglio i dati copiati
            With ThisWorkbook.Worksheets(v)
                .Range("A1").PasteSpecial
                'elimino la colonna A che contiene ripetuto il dato
                'presente nel nome del foglio
                .Columns("A:A").Delete
               
               
                '===== ATTENZIONE =================================================
                '
                'questa parte della macro è *qualcosa in più* che
                'aggiunge un totale alla fine di colonna B;
                'eliminarla se non si ha questa esigenza
                '
                'va ADATTATA con i propri riferimenti se utilizzata
                '
               
                'trovo l'ultima riga della colonna A
                lRigaTot = .Range("A" & .Rows.Count).End(xlUp).Row + 1
                'ricavo il totale e lo scrivo nell'ultima cella della colonna B
                .Range("B" & lRigaTot).Value = "=SUM(B2:B" & lRigaTot - 1 & ")"
                'aggiungo e formatto la scritta Totale
                With .Range("A" & lRigaTot)
                    .Value = "Totale"
                    .Font.Bold = True
                    .HorizontalAlignment = xlRight
                    .Offset(0, 1).Font.Bold = True
                End With
               
                '===================================================================
                       
                'seleziono la cella A1
                .Range("A1").Select
                'eseguo l'Autofit sulle colonne da A a Z
                '(posso ovviamnete decidere per un numero
                'maggiore o minore di colonne)
                .Columns("A:Z").EntireColumn.AutoFit
                'creo un nuovo file con il foglio del nominativo
                'relativo a v
                .Move
                'il nuovo file è quello attivo
                With ActiveWorkbook
                    'non voglio siano visualizzati alert
                    Application.DisplayAlerts = False
                    'salvo il nuovo file
                    .SaveAs sPath & v
                    If Err.Number = 0 Then
                        'chiudo il file
                        .Close
                    End If
                    'ripristono gli alert
                    Application.DisplayAlerts = True
                    Err.Number = 0
                End With
            End With
        Next
       
        Application.CutCopyMode = False
       
        'tolgo il filtro dalla tabella
        .Range("$A$1").AutoFilter
       
    End With
   
    'ripristino l'aggiornamento del monitor
    Application.ScreenUpdating = True
   
    'Set a Nothing delle variabili oggetto
    Set col = Nothing
    Set sh = Nothing
   
End Sub

[scanacc]

PS
1) Il codice va copia/incollato in un modulo standard e va modificato il nome del foglio con la tabella iniziale (nell'esempio Foglio1)
2) Nella griglia non devono esserci spazi vuoti.
3) I file verranno salvati nella stessa cartella dove si trova il file che contiene il codice. Se vuoi salvarli in altra cartella, modifica la parte in grassetto di questa riga di codice: sPath = ThisWorkbook.Path & "\" in: sPath = "C:\NomeDellaDirectory\" dove C:\NomeDellaDirectory va sostituito con il percorso e il nome della vostra directory.
4) Il codice sovrascrive eventuali fogli presenti con lo stesso nome (ma io, per maggior sicurezza, cancello sempre i vecchi)
5) A me da dei problemi nei casi di nome e cognome che terminano con una vocale accentata. Io rimedio togliendo manualmente l'accento

[patel]

Vorrei impostare una macro in modo che mi crei un file excel diverso per ogni agente (in colonna A) con tutte le altre informazioni delle colonne corrispondenti e lo salvi nella cartella dove è presente il file principale.

Quindi i file creati dovrebbero avere un foglio con una sola riga ?
se non è così allega il risultato desiderato per un nome

[walter_sign]

I file creati dovrebbero avere tante righe quante sono quelle del database iniziale riferite allo stesso nominativo.
esempio:
https://dl.dropboxusercontent.com/u/708 ... ltato.xlsx
Grazie.

Grazie anche a scanacc, la sto provando, ti faccio sapere.

[patel]

prova questa

Codice: Seleziona tutto

Public Sub m()
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set sh = ThisWorkbook.Worksheets("Foglio1")
sPath = ThisWorkbook.Path & "\"
LR = Range("A" & Rows.Count).End(xlUp).Row
Range("A1").Select
sh.Sort.SortFields.Clear
sh.Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortTextAsNumbers
With sh.Sort
  .SetRange Range("A2:D" & LR)
  .Header = xlNo
  .MatchCase = False
  .Orientation = xlTopToBottom
  .SortMethod = xlPinYin
  .Apply
End With
Set headers = Range("A1:D1")
j = 2
i = j
sName = sh.Cells(j, 1).Value
Do While sName <> ""
  sh.Activate
  i = i + 1
  Do While Cells(i, 1).Value = sName
     i = i + 1
  Loop
  ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
  Sheets(Sheets.Count).Name = sName
  Set nsh = Sheets(sName)
  headers.Copy nsh.Range("A1")
  sh.Range("A" & j & ":D" & i - 1).Copy nsh.Range("A2")
  nsh.Cells.Columns.AutoFit
  Application.CutCopyMode = False
  j = i
  ActiveSheet.Copy
  ActiveWorkbook.SaveAs Filename:= _
            sPath & sName & ".xlsx", FileFormat:= _
            xlOpenXMLWorkbook, CreateBackup:=False
  ActiveWorkbook.Close
  ActiveSheet.Delete
  sName = sh.Cells(j, 1).Value
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

[scanacc]

Ottima! Della serie .... "Tutte le strade portano a Roma"

[walter_sign]

Fantastici tutti e due. Grazie.