Sommare righe uguali e eliminare doppioni

[SemiuccioPartecipante Semiuccio]

Ciao a tutti.

Sono a chiedere ancora una volta una dritta per risolvere un problema.

Nel foglio di esempio che allego vorrei unire le righe che hanno DATA, GRUPPO1 e GRUPPO2 uguali sommando i valori contenuti nel GRUPPO3. inoltre vorrei eliminare le righe doppione conservando solo una riga con la somma ottenuta.

Grazie

Scusate ho aggiornato il file inviato

Allegati:

You must be logged in to view attached files.

[alexps81Moderatore alexps81 Karma: 55 pts]

Ciao, spero di aver capito...

Magari si può evitare qualche ciclo For ma sono andato abbastanza di fretta.

Questo codice agisce nel "Foglio1". Se deve girare su altri fogli allora devi cambiare il riferimento.

Scrive il risultato nelle colonne F, G, H e I. 

A te eventuali modifiche dove deve essere scritto sul foglio.

Sub somma_e_accorpa()
    Dim ur As Long
    Dim x As Integer, j As Integer
    Dim dict As Object
    Dim somma As Double
    Dim cell As Range
    Dim record As String
    Dim k As Variant, vettori As Variant
    
    ur = ThisWorkbook.Worksheets("Foglio1").Cells(Rows.Count, "A").End(xlUp).Row
    
    If ur < 3 Then Exit Sub
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each cell In ThisWorkbook.Worksheets("Foglio1").Range("A3:A" & ur)
        record = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
        If Not dict.Exists(record) Then
            dict.Add record, cell.Offset(, 3).Value
        Else
            dict(record) = dict(record) + cell.Offset(, 3).Value
        End If
    Next cell
    
    'da questo punto in poi viene scritto il dizionario sul foglio _
    modificare i riferimenti delle celle ed eventualmente cancellare prima _
    il contenuto delle celle per far posto ai nuovi contenuti
    x = 3
    For Each k In dict.Keys
        vettori = Split(k, "|")
        For j = LBound(vettori) To UBound(vettori)
            Cells(x, j + 6).Value = vettori(j)
        Next j
        Cells(x, "I").Value = dict(k)
        x = x + 1
    Next k
    
    Set dict = Nothing
End Sub

[SemiuccioPartecipante Semiuccio]

Grazie Alex. Ho modificato qualcosa perchè volevo sostituire le celle sempre sulle colonne da A a D. Va tutto ok. Solo non riesco a capire come sostituire il formato data che tu hai, con il formato data gg,mm,yy.

Ancora grazie

[alexps81Moderatore alexps81 Karma: 55 pts]

Sostituisci il For Each k In dict.Keys con questo:

    For Each k In dict.Keys
        vettori = Split(k, "|")
        For j = LBound(vettori) To UBound(vettori)
            If IsDate(vettori(j)) Then
                Cells(x, j + 6).Value = CDate(vettori(j))
                Cells(x, j + 6).NumberFormat = "dd/mm/yy"
            Else
                Cells(x, j + 6).Value = vettori(j)
            End If
        Next j
        Cells(x, "I").Value = dict(k)
        x = x + 1
    Next k

Chiaramente dovrai adattare nuovamente il codice (x e j + 6) per scrivere nelle colonne che t'interessano.

[SemiuccioPartecipante Semiuccio]

Ciao Alexs. Mi sono accorto che nei miei dati ho un gruppo4 che avevo sottovalutato. Questo gruppo deve essere riportato e non avrà mai doppioni da sommare. Ho provato, sulla scorta dei tuoi suggerimenti, a trovare una soluzione ma non sono riuscito. Se non ti creo troppo distrurbo, ti allego il file esempio2 che contiene il tuo codice aggiornato e i miei dati tipo anch'essi aggiornati.

Ti saluto e ti auguro una buona Pasqua.

Allegati:

You must be logged in to view attached files.

[alexps81Moderatore alexps81 Karma: 55 pts]

Ciao, prova così e vedi se funziona:

Sub somma_e_accorpa()
    Dim ur As Long
    Dim x As Integer, j As Integer
    Dim dict As Object
    Dim somma As Double
    Dim cell As Range
    Dim record As String
    Dim k As Variant, vettori As Variant
    
    ur = ThisWorkbook.Worksheets("2025").Cells(Rows.Count, "A").End(xlUp).Row
    
    If ur < 3 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each cell In ThisWorkbook.Worksheets("2025").Range("A3:A" & ur)
        record = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
        If IsEmpty(cell.Offset(, 4).Value) Then
            If Not dict.Exists(record) Then
                dict.Add record, cell.Offset(, 3).Value
            Else
                dict(record) = dict(record) + cell.Offset(, 3).Value + cell.Offset(, 4).Value
            End If
        Else
            dict.Add record, cell.Offset(, 4).Value
        End If
    Next cell
    
    'da questo punto in poi viene scritto il dizionario sul foglio _
    modificare i riferimenti delle celle ed eventualmente cancellare prima _
    il contenuto delle celle per far posto ai nuovi contenuti
    x = 3
'    Range("A3:E" & ur).Clear
    For Each k In dict.Keys
        vettori = Split(k, "|")
        For j = LBound(vettori) To UBound(vettori)
            If IsDate(vettori(j)) Then
                Cells(x, j + 6).Value = CDate(vettori(j))
                Cells(x, j + 6).NumberFormat = "dd/mm/yy"
            Else
                Cells(x, j + 6).Value = vettori(j)
            End If
        Next j
        Cells(x, "I").Value = dict(k)
        Cells(x, "I").NumberFormat = "0.00"
        x = x + 1
    Next k
    
    Set dict = Nothing
    Set cell = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "Finito!", vbInformation
End Sub

[SemiuccioPartecipante Semiuccio]

mi segna nella colonna di GRUPPO3  quello che dovrebbe andare nella colonna del GRUPPO4

[alexps81Moderatore alexps81 Karma: 55 pts]

Credevo andassero bene tutti raccolti in una colonna. Va be', prova così adesso:

`Sub somma_e_accorpa()
    Dim ur As Long
    Dim x As Integer, j As Integer
    Dim dict As Object
    Dim somma As Double
    Dim cell As Range
    Dim record As String
    Dim k As Variant, vettori As Variant
    
    ur = ThisWorkbook.Worksheets("2025").Cells(Rows.Count, "A").End(xlUp).Row
    
    If ur < 3 Then Exit Sub
    
    Application.ScreenUpdating = False
    
    Set dict = CreateObject("Scripting.Dictionary")
    
    For Each cell In ThisWorkbook.Worksheets("2025").Range("A3:A" & ur)
        record = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
        If IsEmpty(cell.Offset(, 4).Value) Then
            If Not dict.Exists(record) Then
                dict.Add record, cell.Offset(, 3).Value
            Else
                dict(record) = dict(record) + cell.Offset(, 3).Value + cell.Offset(, 4).Value
            End If
        Else
            dict.Add record, cell.Offset(, 4).Value & "~"
        End If
    Next cell
    
    'da questo punto in poi viene scritto il dizionario sul foglio _
    modificare i riferimenti delle celle ed eventualmente cancellare prima _
    il contenuto delle celle per far posto ai nuovi contenuti
    x = 3
'    Range("A3:E" & ur).Clear
    For Each k In dict.Keys
        vettori = Split(k, "|")
        For j = LBound(vettori) To UBound(vettori)
            If IsDate(vettori(j)) Then
                Cells(x, j + 6).Value = CDate(vettori(j))
                Cells(x, j + 6).NumberFormat = "dd/mm/yy"
            Else
                Cells(x, j + 6).Value = vettori(j)
            End If
        Next j
        If Right(dict(k), 1) = "~" Then
            Cells(x, "J").NumberFormat = "0.00"
            Cells(x, "J").Value = Left(dict(k), Len(dict(k)) - 1)
        Else
            Cells(x, "I").NumberFormat = "0.00"
            Cells(x, "I").Value = dict(k)
        End If
        x = x + 1
    Next k
    
    Set dict = Nothing
    Set cell = Nothing
    Application.ScreenUpdating = True
    
    MsgBox "Finito!", vbInformation
End Sub

[SemiuccioPartecipante Semiuccio]

Perfetto. Grazie ancora e ti auguro nuovamente una Pasqua Felice.

Ciao

[scossaPartecipante scossa Karma: 37 pts]

alexps81 ha scritto:

. Va be', prova così adesso:

 

Un'alternativa potrebbe essere usare un array.

Cambiando così le relative istruzioni nel priomo ciclo For Each cell in cui alimenti il dictionary :

        If Not dict.Exists(record) Then
            dict.Add record, Array(cell.Offset(, 3).Value, cell.Offset(, 4).Value)
        Else
            dict(record)(0) = dict(record)(0) + cell.Offset(, 3).Value
            dict(record)(1) = dict(record)(1) + cell.Offset(, 4).Value
        End If

e poi così quello in cui scrivi i valori sul foglio:

        Cells(x, "I").Value = dict(k)(0)
        Cells(x, "J").Value = dict(k)(1)

P.S.: se a inizio codice metti Application.ScreenUpdating = False e a fine codice lo ripristini con Application.ScreenUpdating = True guadagni molto in velocità di esecuzione.

Per comodità riporto il codice della sub completa:

Sub somma_e_accorpa()
    Dim ur As Long
    Dim x As Integer, j As Integer
    Dim dict As Object
    Dim somma As Double
    Dim cell As Range
    Dim record As String
    Dim k As Variant, vettori As Variant
    
    ur = ThisWorkbook.Worksheets("2025").Cells(Rows.Count, "A").End(xlUp).Row
    
    If ur < 3 Then Exit Sub
    
    Set dict = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    For Each cell In ThisWorkbook.Worksheets("2025").Range("A3:A" & ur)
        record = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
        If Not dict.Exists(record) Then
            dict.Add record, Array(cell.Offset(, 3).Value, cell.Offset(, 4).Value)
        Else
            dict(record)(0) = dict(record)(0) + cell.Offset(, 3).Value
            dict(record)(1) = dict(record)(1) + cell.Offset(, 4).Value
        End If
    Next cell
    
    'da questo punto in poi viene scritto il dizionario sul foglio _
    modificare i riferimenti delle celle ed eventualmente cancellare prima _
    il contenuto delle celle per far posto ai nuovi contenuti
    x = 3
'    Range("A3:E" & ur).Clear
    For Each k In dict.Keys
        vettori = Split(k, "|")
        For j = LBound(vettori) To UBound(vettori)
            If IsDate(vettori(j)) Then
                Cells(x, j + 6).Value = CDate(vettori(j))
                Cells(x, j + 6).NumberFormat = "dd/mm/yy"
            Else
                Cells(x, j + 6).Value = vettori(j)
            End If
        Next j
        Cells(x, "I").Value = dict(k)(0)
        Cells(x, "J").Value = dict(k)(1)
        x = x + 1
    Next k
    Application.ScreenUpdating = True
End Sub

[alexps81Moderatore alexps81 Karma: 55 pts]

scossa ha scritto:

Cambiando così le relative istruzioni nel priomo ciclo For Each cell in cui alimenti il dictionary

Giusto giusto   ottimo. Thanks.

scossa ha scritto:

P.S.: se a inizio codice metti Application.ScreenUpdating = False e a fine codice lo ripristini con Application.ScreenUpdating = True guadagni molto in velocità di esecuzione.

Si certo, nel mio codice sono presenti. Torna a True poco dopo la distruzione degli oggetti dict e cell

 

[SemiuccioPartecipante Semiuccio]

Scusa Scossa, ma il tuo codice non mi ha sommato le righe che doveva sommare.

[alexps81Moderatore alexps81 Karma: 55 pts]

Semiuccio ha scritto:

non mi ha sommato le righe che doveva sommare

Si certo, questo problema nasce perché utilizzando un Array per l'assegnazione dei valori esso viene passato come VALORE (ByVal) e non come RIFERIMENTO (ByRef). Viene perciò modificata una copia. Bisogno appoggiare i dati ad una variabile temporanea, eseguire le somme e riassegnare alla Array del Dizionario il contenuto della variabile temporanea.

In altre parole:

Option Explicit

Sub somma_e_accorpa()
    Dim ur As Long
    Dim x As Integer, j As Integer
    Dim dict As Object
    Dim somma As Double
    Dim cell As Range
    Dim record As String
    Dim k As Variant, vettori As Variant
    Dim tempArray As Variant
    
    ur = ThisWorkbook.Worksheets("2025").Cells(Rows.Count, "A").End(xlUp).Row
    
    If ur < 3 Then Exit Sub
    
    Set dict = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    For Each cell In ThisWorkbook.Worksheets("2025").Range("A3:A" & ur)
        record = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value
        If Not dict.Exists(record) Then
            dict.Add record, Array(cell.Offset(, 3).Value, cell.Offset(, 4).Value)
        Else
            tempArray = dict(record)
            tempArray(0) = tempArray(0) + cell.Offset(, 3).Value
            tempArray(1) = tempArray(1) + cell.Offset(, 4).Value
            
            dict(record) = tempArray
        End If
    Next cell
    
    'da questo punto in poi viene scritto il dizionario sul foglio _
    modificare i riferimenti delle celle ed eventualmente cancellare prima _
    il contenuto delle celle per far posto ai nuovi contenuti
    x = 3
'    Range("A3:E" & ur).Clear
    For Each k In dict.Keys
        vettori = Split(k, "|")
        For j = LBound(vettori) To UBound(vettori)
            If IsDate(vettori(j)) Then
                Cells(x, j + 6).Value = CDate(vettori(j))
                Cells(x, j + 6).NumberFormat = "dd/mm/yy"
            Else
                Cells(x, j + 6).Value = vettori(j)
            End If
        Next j
        Cells(x, "I").Value = dict(k)(0)
        Cells(x, "I").NumberFormat = "0.00"
        Cells(x, "J").Value = dict(k)(1)
        Cells(x, "J").NumberFormat = "0.00"
        x = x + 1
    Next k
    
    Set dict = Nothing
    Set cell = Nothing
    Application.ScreenUpdating = True
End Sub

[SemiuccioPartecipante Semiuccio]

alexps81 ha scritto:

Dim ur As Long Dim x As Integer, j As Integer Dim dict As Object Dim somma As Double Dim cell As Range Dim record As String Dim k As Variant, vettori As Variant Dim tempArray As Variant ur = ThisWorkbook.Worksheets("2025").Cells(Rows.Count, "A").End(xlUp).Row If ur < 3 Then Exit Sub Set dict = CreateObject("Scripting.Dictionary") Application.ScreenUpdating = False For Each cell In ThisWorkbook.Worksheets("2025").Range("A3:A" & ur) record = cell.Value & "|" & cell.Offset(, 1).Value & "|" & cell.Offset(, 2).Value If Not dict.Exists(record) Then dict.Add record, Array(cell.Offset(, 3).Value, cell.Offset(, 4).Value) Else tempArray = dict(record) tempArray(0) = tempArray(0) + cell.Offset(, 3).Value tempArray(1) = tempArray(1) + cell.Offset(, 4).Value dict(record) = tempArray End If Next cell 'da questo punto in poi viene scritto il dizionario sul foglio _ modificare i riferimenti delle celle ed eventualmente cancellare prima _ il contenuto delle celle per far posto ai nuovi contenuti x = 3' Range("A3:E" & ur).Clear For Each k In dict.Keys vettori = Split(k, "|") For j = LBound(vettori) To UBound(vettori) If IsDate(vettori(j)) Then Cells(x, j + 6).Value = CDate(vettori(j)) Cells(x, j + 6).NumberFormat = "dd/mm/yy" Else Cells(x, j + 6).Value = vettori(j) End If Next j Cells(x, "I").Value = dict(k)(0) Cells(x, "I").NumberFormat = "0.00" Cells(x, "J").Value = dict(k)(1) Cells(x, "J").NumberFormat = "0.00" x = x + 1 Next k Set dict = Nothing Set cell = Nothing Application.ScreenUpdating = True

Ok e grazie ad entrambi. Ancora auguri di buona Pasqua

[scossaPartecipante scossa Karma: 37 pts]

alexps81 ha scritto:

Si certo, questo problema nasce perché utilizzando un Array per l'assegnazione dei valori esso viene passato come VALORE (ByVal) e non come RIFERIMENTO (ByRef). Viene perciò modificata una copia. Bisogno appoggiare i dati ad una variabile temporanea, eseguire le somme e riassegnare alla Array del Dizionario il contenuto della variabile temporanea.

Ciao,

in realtà la soluzione è molto più semplice, basta correggere l'assegnazione: modifica questa parte del mio codice da

        Else
            dict(record)(0) = dict(record)(0) + cell.Offset(, 3).Value
            dict(record)(1) = dict(record)(1) + cell.Offset(, 4).Value
        End If

a

        Else
            dict(record) = Array(dict(record)(0) + cell.Offset(0, 3).Value, dict(record)(1) + cell.Offset(0, 4).Value)
        End If

C'è solo una sbavatura: alcuni 0 nell'ultima colonna, ma purtroppo il pc mi ha piantato in asso e, al momento, non riesco a sistemare.

Una patch al volo: sostituire l'istruzione che scrive nella colonna j con questa:

Cells(x, "J").Value = IIf(dict(k)(1) > 0, dict(k)(1), "")

[SemiuccioPartecipante Semiuccio]

Grazie ragazzi. Funziona tutto alla perfezione.   

[LukeRedsPartecipante LukeReds Karma: 13 pts]

ciao,

tanto per esercizio, se ho capito correttamente il problema, soluzione con formula perexcal 365. Dove vuoi, formula matriciale (si espande da sola)

=LET(d;UNICI(A3:C100);STACK.ORIZ(d;SOMMA.PIÙ.SE(D3:D100;A3:A100;SCEGLI.COL(d;1);B3:B100;SCEGLI.COL(d;2);C3:C100;SCEGLI.COL(d;3))))

Vba (cancella i vecchi dati sostituendoli con quelli aggregati)

`Sub Accorpa()
Dim c As Integer, Dict As Object, r As Integer, dati, stringa As String
r = Range("A" & Rows.Count).End(xlUp).Row
Set Dict = CreateObject("Scripting.Dictionary")
For i = 3 To r
   stringa = Cells(i, 1) & "\" & Cells(i, 2) & "\" & Cells(i, 3)
   qta = Cells(i, 4)
   Dict(stringa) = Dict(stringa) + qta
Next i
i = 2
Range("A3:D100").Clear
For Each k In Dict.Keys
    i = i + 1
    'Cells(i, 6) = k
    dati = Split(k, "\")
    For c = 0 To 2
       Cells(i, c + 1) = dati(c)
    Next c
    Cells(i, 4) = Dict(k)
Next k
End Sub`

[Autore]

Articoli