gruppa in excel

Hai un problema con Excel?

Nuova discussione

gruppa in excel
di gugluca (utente non iscritto) data: 23/01/2014 19:26:49
Ciao a tutti,
ho più file tutti strutturati ugualmente con un foglio solo alimentato e 2 colonne, la colonna A con dei nomi e la colonna B con dei valori.

Vorrei trovare una macro che generasse un nuovo file con la somma raggruppata per la colonna A di tutti i valori della colonna B di tutti i file.

Ho provato a creare una macro, ma è macchinosa e lenta in tutti i passaggi (soprattutto per il metodo che ho trovato per gruppare).

Vi riporto sotto il codice

Qualcuno sa come posso migliorare il tutto, eventualmente cambiando completamente metodo?

Grazie in anticipo

Buona serata

Luca

Sub inserisci_transazioni()

Dim risposta
Dim file_calc, foglio_calc, file_temp, foglio_temp
Dim i, k, fine, valore As Long
Dim lRow As Long
Dim ItemRow1, ItemRow2 As String
Dim lengthRow1, lengthRow2 As String


Set file_calc = Workbooks("Transazioni per servizio.xlsm")
Set foglio_calc = file_calc.Worksheets("DB")

foglio_calc.Activate
Rows("2:1048000").Select
Selection.Delete Shift:=xlUp
Selection.ClearContents

    risposta = vbYes

    While risposta = vbYes
        risposta = MsgBox("Vuoi caricare un altro mese?", vbYesNo, "seleziona file")
        If risposta = vbYes Then
        Percorso = Excel.Application.GetOpenFilename("File Excel (*.xlsx; *.xls), *.xlsx; *.xls", , "Selezionare il file Excel CPU", "Apri", "False")
        Workbooks.Open Filename:=Percorso
        
        Set file_temp = Workbooks(ActiveWorkbook.Name)
        Set foglio_temp = file_temp.Worksheets(ActiveSheet.Name)
            
        fine = foglio_temp.Range("a1048576").End(xlUp).Row
        inizio = foglio_calc.Range("a1048576").End(xlUp).Row
        
        i = fine
        k = inizio + 1
        
        While i > 1
        
        foglio_calc.Cells(k, 1) = foglio_temp.Cells(i, 5)
        foglio_calc.Cells(k, 2) = foglio_temp.Cells(i, 7)
             
        i = i - 1
        k = k + 1
            
        Wend

        file_temp.Close (no)
        
        Else

        End If      
    
    Wend
   
foglio_calc.Activate
Cells.Select

Selection.Sort _
        Key1:=Range("A2"), Order1:=xlAscending, _
        Header:=xlYes, OrderCustom:=1, _
        MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal

    lRow = 2
    
    fine = foglio_calc.Range("a1048576").End(xlUp).Row

    Do While (Cells(lRow, 1) <> "") < fine
           
        ItemRow1 = Cells(lRow, "A")
        ItemRow2 = Cells(lRow + 1, "A")
                      
        If ((ItemRow1 = ItemRow2)) Then
            Cells(lRow, "B") = Cells(lRow, "B") + Cells(lRow + 1, "B")
            Rows(lRow + 1).Delete
       
        Else
            lRow = lRow + 1
        End If
    Loop

End Sub

di patel data: 23/01/2014 20:36:03
sarebbe meglio allegare un file di esempio con anche il risultato desiderato
di gugluca (utente non iscritto) data: 24/01/2014 08:37:20
Ciao
ho allegato 2 file (fileA e fileB) con ciascuno nel primo foglio una tabella identica.
Ho allegato anche il 'file finale' con una tabella nel primo foglio che somma e raggruppa per 'NOME' le altre due tabelle dei fileA e fileB.

In sostanza la macro che ho creato prevede che il file finale sia esistente, pulisce la tabella finale, richiede l'apertura dei file excel (i fileA e fileB) che possono essere molti, inserisce accodandoli nel file finale tutti i dati (nella macro chiamato DB).
Nell'ultima parte, la macro che ho creato, per raggruppare i NOMI sommando i VALORI, ordina per NOMI e somma i VALORI eliminando i NOMI (in modo da raggrupparli).
Non sapevo come fare una query sql che mi avrebbe aiutato molto, del tipo: SELECT NOMI, SUM(VALORI) AS VALORI FROM TABELLA_FINALE GROUP BY NOMI. Inserendo i valori nello stesso foglio del file finale (eliminando i valori contenuti nella tabella del file finale e lasciando solo i valori derivanti dal risultato della query).

Il processo svolto con la mia macro è molto macchinoso e contorto.
Una volta salvato i fileA e fileB (ed altri dello stesso tipo) nello stesso percorso, la cosa ideale sarebbe far in modo che la macro apra tutti i file della cartella, e senza neanche copiarli accodandoli in un altro file, riporti direttamente in un nuovo file (del tipo file finale) il risultato che voglio ottenere.

Spero di essermi spiegato meglio.

Grazie ancora per l'aiuto

Ciao

Luca
di Grograman data: 24/01/2014 10:33:42
Ti ho allegato un file di eempio "filefinale2" con un codice che prevede di avere tutti e 3 i file che hai allegato tu aperti contemporaneamente (cioè, il finale 2 e A + B )

Sarebbe da personalizzare con nomi dei file ed eventuali percorsi, ma ora di meglio non posso fare!

Occhio ai nomi, hai degli spazi dopo alcuni nomi.

di Grograman data: 24/01/2014 10:34:01

Option Explicit

Sub Nomesub()
  Dim wb As Workbook, wbA As Workbook, wbB As Workbook
  Dim ws As Worksheet, wsA As Worksheet, wsB As Worksheet
  Dim x As Long, y As Long
  Dim oPvtCch As PivotCache
  Dim oPvtTbl As PivotTable
  Dim ptField As PivotField
  Dim ptItem As PivotItem
  Dim rngDati As Range
  
  
  'DA MODIFICARE SUI NOMI DEI FILE E PREVEDERE DI APRIRLI, ORA PREVEDE DI AVERE LE 3 CARTELLE APERTE CONTEMPORANEAMENTE
  Set wb = ThisWorkbook
  Set ws = wb.Worksheets.Add
  
  Set wbA = Application.Workbooks("fileA.xlsx")
  Set wsA = wbA.Worksheets(1)

  Set wbB = Application.Workbooks("fileB.xlsx")
  Set wsB = wbB.Worksheets(1)

  'COPIO COLONNE CELLE A:B DI FILE A NEL FILE FINALE
  x = wsA.Range("A" & wsA.Rows.Count).End(xlUp).Row
  wsA.Range("A1:B" & x).Copy ws.Cells(1, 1)
  
  'COPIO COLONNE CELLE A:B DI FILE B NEL FILE FINALE
  y = wsB.Range("A" & wsB.Rows.Count).End(xlUp).Row
  wsB.Range("A2:B" & x).Copy ws.Cells(x + 1, 1)
  
  'PIVOTTIZZO I DATI ACCODATI
  x = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
  Set rngDati = ws.Range("a1:b" & x)
  Set oPvtCch = ws.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngDati)
  Set oPvtTbl = oPvtCch.CreatePivotTable(ws.Cells(2, 5))
  With oPvtTbl
    .RowAxisLayout xlOutlineRow
    .Name = ws.Name
    .PivotFields(1).Orientation = xlRowField
    .PivotFields(1).Position = 1
    .AddDataField .PivotFields(2), "Totale", xlSum
  End With

  Set ws = Nothing
  Set wb = Nothing
  Set wbA = Nothing
  Set wsA = Nothing
  Set wbB = Nothing
  Set wsB = Nothing
  Set rngDati = Nothing
  Set oPvtCch = Nothing
  Set oPvtTbl = Nothing
End Sub

di Grograman data: 24/01/2014 10:34:58
Nella copia dal file B ho lasciato la X, invece ci vuole una Y!

  'COPIO COLONNE CELLE A:B DI FILE B NEL FILE FINALE
  y = wsB.Range("A" & wsB.Rows.Count).End(xlUp).Row
  wsB.Range("A2:B" & y).Copy ws.Cells(x + 1, 1)

di Grograman data: 24/01/2014 10:44:07
Per gli spazi in modo brutale:

  'PIVOTTIZZO I DATI ACCODATI
  x = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
  Set rngDati = ws.Range("a1:b" & x)
  rngDati.Columns(1).Replace What:=" ", Replacement:=""

di gugluca (utente non iscritto) data: 24/01/2014 12:24:18
Ciao,
grazie per la risposta e per la soluzione.
Unica cosa, non c'è la possibilità di evitare l'uso della Pivot, risolvendo con una query sql, impostando la tabella creata nel file finale (nel foglio ws)?
di gugluca (utente non iscritto) data: 24/01/2014 12:39:05
Inoltre la macro, nella riga sotto riportata mi riporta questo errore: 'tipo non corrispondente'
Ho provata a girarla con circa 30.000 righe e funziona.
Con 400.000 righe come ho nel complesso mi esce fuori l'errore.

Eppure i dati sono omogenei..
Set oPvtCch = foglio_calc.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngDati)

di Grograman data: 24/01/2014 12:57:09
Intanto che cerco di capire come renderla più leggibile, prova così:

Per le 400.000 righe invece prova a modificare
SourceData:=rngDati
in
SourceData:=rngDati.address

Option Explicit

Sub Nomesub()
  Dim wb As Workbook, wbA As Workbook, wbB As Workbook
  Dim ws As Worksheet, wsA As Worksheet, wsB As Worksheet
  Dim x As Long, y As Long
  Dim oPvtCch As PivotCache
  Dim oPvtTbl As PivotTable
  Dim ptField As PivotField
  Dim ptItem As PivotItem
  Dim rngDati As Range
  
  
  'DA MODIFICARE SUI NOMI DEI FILE E PREVEDERE DI APRIRLI, ORA PREVEDE DI AVERE LE 3 CARTELLE APERTE CONTEMPORANEAMENTE
  Set wb = ThisWorkbook
  Set ws = wb.Worksheets.Add
  
  Set wbA = Application.Workbooks("fileA.xlsx")
  Set wsA = wbA.Worksheets(1)

  Set wbB = Application.Workbooks("fileB.xlsx")
  Set wsB = wbB.Worksheets(1)

  'COPIO COLONNE CELLE A:B DI FILE A NEL FILE FINALE
  x = wsA.Range("A" & wsA.Rows.Count).End(xlUp).Row
  wsA.Range("A1:B" & x).Copy ws.Cells(1, 1)
  
  'COPIO COLONNE CELLE A:B DI FILE B NEL FILE FINALE
  y = wsB.Range("A" & wsB.Rows.Count).End(xlUp).Row
  wsB.Range("A2:B" & x).Copy ws.Cells(x + 1, 1)
  
  'PIVOTTIZZO I DATI ACCODATI
  x = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
  Set rngDati = ws.Range("a1:b" & x)
  rngDati.Columns(1).Replace What:=" ", Replacement:=""
  Set oPvtCch = ws.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngDati)
  Set oPvtTbl = oPvtCch.CreatePivotTable(ws.Cells(2, 5))
  With oPvtTbl
    .RowAxisLayout xlOutlineRow
    .Name = ws.Name
    .PivotFields(1).Orientation = xlRowField
    .PivotFields(1).Position = 1
    .AddDataField .PivotFields(2), "Totale", xlSum
  End With
   
  'PROVIAMO CON MSQUERY
  With ws.ListObjects.Add(SourceType:=0, Source:="ODBC;DSN=Excel Files;DBQ=" & wb.FullName & ";DefaultDir=" & wb.Path & ";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
    , Destination:=ws.Cells(2, 8)).QueryTable
    .CommandText = Array("SELECT `" & ws.Name & "$`.NOMI, Sum(`" & ws.Name & "$`.VALORI) AS 'VALORI'" & Chr(13) & "" & Chr(10) & _
    "FROM `" & ws.Name & "$` `" & ws.Name & "$`" & Chr(13) & "" & Chr(10) & "GROUP BY `" & ws.Name & "$`.NOMI")
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .PreserveColumnInfo = True
    .ListObject.DisplayName = ws.Name
    .Refresh BackgroundQuery:=False
  End With

  Set ws = Nothing
  Set wb = Nothing
  Set wbA = Nothing
  Set wsA = Nothing
  Set wbB = Nothing
  Set wsB = Nothing
  Set rngDati = Nothing
  Set oPvtCch = Nothing
  Set oPvtTbl = Nothing
End Sub

di Grograman data: 24/01/2014 13:05:19
Ok non sarà il massimo della bellezza, ma dovrebbe funzionare!

  'PROVIAMO CON MSQUERY
  With ws.ListObjects.Add(SourceType:=0, Source:="ODBC;DSN=Excel Files;DBQ=" & wb.FullName & _
                ";DefaultDir=" & wb.Path & ";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
                , Destination:=ws.Cells(2, 8)).QueryTable
    .CommandText = "SELECT `" & ws.Name & "$`.NOMI, Sum(`" & ws.Name & "$`.VALORI) AS VALORI" & Chr(13) _
          & "" & "FROM `" & ws.Name & "$` `" & ws.Name & "$`" & Chr(13) & "" & "GROUP BY `" & ws.Name & "$`.NOMI"
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlOverwriteCells 'messo overwrite qualora volessi usare sempre lo stesso foglio
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .PreserveColumnInfo = True
    .ListObject.DisplayName = ws.Name
    .Refresh BackgroundQuery:=False
  End With

di Grograman data: 24/01/2014 13:10:23
Così mi funziona anche su 6-700k righe, ma non ho guardato se sia più rapida la pivot o la query:

Option Explicit

Sub Nomesub()
  Dim wb As Workbook, wbA As Workbook, wbB As Workbook
  Dim ws As Worksheet, wsA As Worksheet, wsB As Worksheet
  Dim x As Long, y As Long
  Dim oPvtCch As PivotCache
  Dim oPvtTbl As PivotTable
  Dim ptField As PivotField
  Dim ptItem As PivotItem
  Dim rngDati As Range
  
  
  'DA MODIFICARE SUI NOMI DEI FILE E PREVEDERE DI APRIRLI, ORA PREVEDE DI AVERE LE 3 CARTELLE APERTE CONTEMPORANEAMENTE
  Set wb = ThisWorkbook
  Set ws = wb.Worksheets.Add
  
  Set wbA = Application.Workbooks("fileA.xlsx")
  Set wsA = wbA.Worksheets(1)

  Set wbB = Application.Workbooks("fileB.xlsx")
  Set wsB = wbB.Worksheets(1)

  'COPIO COLONNE CELLE A:B DI FILE A NEL FILE FINALE
  x = wsA.Range("A" & wsA.Rows.Count).End(xlUp).Row
  wsA.Range("A1:B" & x).Copy ws.Cells(1, 1)
  
  'COPIO COLONNE CELLE A:B DI FILE B NEL FILE FINALE
  y = wsB.Range("A" & wsB.Rows.Count).End(xlUp).Row
  wsB.Range("A2:B" & y).Copy ws.Cells(x + 1, 1)
  
  'PIVOTTIZZO I DATI ACCODATI
  x = ws.Range("A" & ws.Rows.Count).End(xlUp).Row
  Set rngDati = ws.Range("a1:b" & x)
  rngDati.Columns(1).Replace What:=" ", Replacement:=""
  Set oPvtCch = ws.Parent.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rngDati.Address)
  Set oPvtTbl = oPvtCch.CreatePivotTable(ws.Cells(2, 5))
  With oPvtTbl
    .RowAxisLayout xlOutlineRow
    .Name = ws.Name
    .PivotFields(1).Orientation = xlRowField
    .PivotFields(1).Position = 1
    .AddDataField .PivotFields(2), "Totale", xlSum
  End With
   
  'PROVIAMO CON MSQUERY
  With ws.ListObjects.Add(SourceType:=0, Source:="ODBC;DSN=Excel Files;DBQ=" & wb.FullName & _
                ";DefaultDir=" & wb.Path & ";DriverId=1046;MaxBufferSize=2048;PageTimeout=5;" _
                , Destination:=ws.Cells(2, 8)).QueryTable
    .CommandText = "SELECT `" & ws.Name & "$`.NOMI, Sum(`" & ws.Name & "$`.VALORI) AS VALORI" & Chr(13) _
          & "" & "FROM `" & ws.Name & "$` `" & ws.Name & "$`" & Chr(13) & "" & "GROUP BY `" & ws.Name & "$`.NOMI"
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlOverwriteCells 'messo overwrite qualora volessi usare sempre lo stesso foglio
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .PreserveColumnInfo = True
    .ListObject.DisplayName = ws.Name
    .Refresh BackgroundQuery:=False
  End With

  Set ws = Nothing
  Set wb = Nothing
  Set wbA = Nothing
  Set wsA = Nothing
  Set wbB = Nothing
  Set wsB = Nothing
  Set rngDati = Nothing
  Set oPvtCch = Nothing
  Set oPvtTbl = Nothing
End Sub

di gugluca (utente non iscritto) data: 24/01/2014 14:31:36
Ciao,
ora la pivot funziona alla grande (ed è praticamente istantanea anche con 400k righe)!!

Per quanto riguarda il 2° modo, quello con la query e collegamento ODBC, mi esce fuori un 'errore generale di ODBC'.
Non so se ho qualche riferimento da inserire che mi perdo..

Grazie di tutto
di Grograman (utente non iscritto) data: 24/01/2014 15:13:38
E allora vai di pivot che la query un pò ci mette (parliamo sempre di 7-8 secondi....).

Per l'errore qulla query non saprei, come dicevono non sono il mio forte, magari vedendolo da te qualche ragno caverei dal buco, ma così non ho idea di cosa possa essere!
di gugluca (utente non iscritto) data: 17/02/2014 09:40:24
Grazie ancora per i consigli
Ciao

Luca

Vuoi Approfondire?