VBA to merge duplicate rows and sum values in certain column

[aydinrotar]

Hi,

I'm trying to automate a really long task I have to preform daily at work with VBA and although I'm almost a complete noob with VBA, I have managed to get majority of it done except for this one last step, so any help would be greatly appreciated.

Basically I have a worksheet with 4 columns of data, I'm looking for some code to check the values in column A and if there's a duplicate, merge the duplicates and sum the values only in column D.

Example:

I need something like this..

[TABLE="width: 500"]
<tbody>[TR]
[TD]NUMBER[/TD]
[TD]NAME[/TD]
[TD]CODE[/TD]
[TD]HOURS[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]John Smith[/TD]
[TD]410[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]John Smith[/TD]
[TD]410[/TD]
[TD]6[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]John Smith[/TD]
[TD]410[/TD]
[TD]8[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Jane Smith[/TD]
[TD]410[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Jane Smith[/TD]
[TD]410[/TD]
[TD]7[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Jane Smith[/TD]
[TD]410[/TD]
[TD]6.5[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Jane Smith[/TD]
[TD]410[/TD]
[TD]6.5[/TD]
[/TR]
</tbody>[/TABLE]

To turn into this..

[TABLE="width: 500"]
<tbody>[TR]
[TD]NUMBER[/TD]
[TD]NAME[/TD]
[TD]CODE[/TD]
[TD]HOURS[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD]John Smith[/TD]
[TD]410[/TD]
[TD]22[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]Jane Smith[/TD]
[TD]410[/TD]
[TD]27[/TD]
[/TR]
</tbody>[/TABLE]


Note: Columns A,B and C will always have the same value if they're a duplicate and only column D needs to be added.


I've found this online but cannot for the life of me work out how to customize it to suite my needs:

[COLOR=blue]Sub[/COLOR] test() 
    [COLOR=blue]Dim[/COLOR] a, i [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR], ii [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR], n [COLOR=blue]As[/COLOR] [COLOR=blue]Long[/COLOR] 
    a = Sheets("STO REV").Cells(1).CurrentRegion.Value 
    n = 1 
    [COLOR=blue]With[/COLOR] CreateObject("Scripting.Dictionary") 
        [COLOR=blue]For[/COLOR] i = 2 [COLOR=blue]To[/COLOR] [COLOR=blue]UBound[/COLOR](a, 1) 
            [COLOR=blue]If[/COLOR] [COLOR=blue]Not[/COLOR] .exists(a(i, 2)) [COLOR=blue]Then[/COLOR] 
                n = n + 1: .Item(a(i, 2)) = n 
                [COLOR=blue]For[/COLOR] ii = 1 [COLOR=blue]To[/COLOR] [COLOR=blue]UBound[/COLOR](a, 2) 
                    a(n, ii) = a(i, ii) 
                [COLOR=blue]Next[/COLOR] 
            [COLOR=blue]Else[/COLOR] 
                a(.Item(a(i, 2)), 5) = a(.Item(a(i, 2)), 5) + a(i, 5) 
            [COLOR=blue]End[/COLOR] [COLOR=blue]If[/COLOR] 
        [COLOR=blue]Next[/COLOR] 
    [COLOR=blue]End With[/COLOR] 
    [COLOR=blue]With[/COLOR] Sheets.Add().Cells(1).Resize(n, [COLOR=blue]UBound[/COLOR](a, 2)) 
        .Value = a 
        .Columns.AutoFit 
    [COLOR=blue]End With[/COLOR] 
[COLOR=blue]End Sub[/COLOR][COLOR=blue]
[/COLOR]

Again, any help would really be appreciated

 

[ajcarlos18]

That worked perfectly Mick, thanks so much for your help.

Regards Aydin

Hi,

I'm following this code of yours and it seems working if the number of column is 4 just like the example. I tried it but the column on my sheet 14 and the code doesn't work. Please help on what to tweak in order for your code to run smoothly.

Thank you very much

 

[ajcarlos18]

Try this:-

[COLOR=Navy]Sub[/COLOR] MG02Sep59
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] nRng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR=Navy]Else[/COLOR]
        [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] nRng = _
        Dn Else [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn)
        .Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
[COLOR=Navy]If[/COLOR] Not nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Hi,

I'm following this code of yours and it seems working if the number of column is 4 just like the example. I tried it but the column on my sheet 14 and the code doesn't work. Please help on what to tweak in order for your code to run smoothly.

Thank you very much

 

[MickG]

Please start a new thread quoting this thread reference and showing an example of your data and your expected results.

 

[sarunas221]

Try this:-

[COLOR=Navy]Sub[/COLOR] MG02Sep59
[COLOR=Navy]Dim[/COLOR] Rng [COLOR=Navy]As[/COLOR] Range, Dn [COLOR=Navy]As[/COLOR] Range, n [COLOR=Navy]As[/COLOR] [COLOR=Navy]Long,[/COLOR] nRng [COLOR=Navy]As[/COLOR] Range
[COLOR=Navy]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
[COLOR=Navy]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
[COLOR=Navy]For[/COLOR] [COLOR=Navy]Each[/COLOR] Dn [COLOR=Navy]In[/COLOR] Rng
    [COLOR=Navy]If[/COLOR] Not .Exists(Dn.Value) [COLOR=Navy]Then[/COLOR]
        .Add Dn.Value, Dn
    [COLOR=Navy]Else[/COLOR]
        [COLOR=Navy]If[/COLOR] nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] [COLOR=Navy]Set[/COLOR] nRng = _
        Dn Else [COLOR=Navy]Set[/COLOR] nRng = Union(nRng, Dn)
        .Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
    [COLOR=Navy]End[/COLOR] If
[COLOR=Navy]Next[/COLOR]
[COLOR=Navy]If[/COLOR] Not nRng [COLOR=Navy]Is[/COLOR] Nothing [COLOR=Navy]Then[/COLOR] nRng.EntireRow.Delete
[COLOR=Navy]End[/COLOR] [COLOR=Navy]With[/COLOR]
[COLOR=Navy]End[/COLOR] [COLOR=Navy]Sub[/COLOR]

Regards Mick

Hi Mick, this code is amazing. it does almost exactly what i need but i need it to compare the not only A range but B range too.
Set Rng = Range(Range("A20"), Range("B" & Rows.Count).End(xlUp))

I tried altering the range i need so it would select 2 columbs instead of 1 but the code gives me an arror
[h=1]Run-time error '1004': Cannot use that command on overlapping selections[/h]
Would you know how to fix this?

 

[sarunas221]

The error appears on the nRgn.EntireRow.Delete code

 

[MickG]

Please start a new thread quoting this thread reference and showing an example of your data and your expected results.

 

[KGee]

I came across this thread and it was exactly what I needed. Just needed a slight tweak as I have to sum the values in E & F for my situation. Thanks Mick!

 

[MickG]

You're welcome

 

[gburns53]

I have a much faster and simple function if you're comfortable with arrays and using dictionary object.

I simplify the function by knowing my value to sum is in column 4. You can adjust code for multiple values in other columns. I'm writing from 1 array to another (InAy to OutAy), the dictionary determines if row already existed. The magic happens in the dictionary's Item property. I assign the item property value to the row (r) when a new OutAy row is written. Then when it exists already, I retrieve the row (r) where it was written to OutAy using the item property value: d.item(KeyIn) I can then update that value in OutAy(r, c) with a sum of existing value and new value 'KeyVal'.
This solves the same as sql query aggregate: "Select a, b, c, sum(d) from data group by a, b, c"
Note: add a tools->reference to Microsoft Scripting runtime

  sub some()

     data = Range("WhereYourDataIs") 'create data array
     Range("WhereYourDataIs").clear 'assumes you'll output to same location
     data = RemoveDupes(data) 'removedupes and sum values
     Range("A2").Resize(UBound(data), UBound(data, 2)) = data 'A2 assumes your data headers begin in row 1, column 1
     ...
    End Sub

Function RemoveDupes(InAy As Variant) As Variant
    Dim d As Scripting.Dictionary
    Set d = New Scripting.Dictionary
    ReDim OutAy(1 To UBound(InAy), 1 To 4)
    r = 1

    For i = 1 To UBound(InAy)
        KeyIn = ""
        KeyVal = InAy(i, 4) 'the value field to sum/aggregate if exists
        For c = 1 To 3 'a, b, c metadata to roll up
            KeyIn = KeyIn & InAy(i, c)
        Next c
        If d.Exists(KeyIn) Then
            OutAy(d.item(KeyIn), 4) = OutAy(d.item(KeyIn), 4) + KeyVal 'the summation of value field for existing row in OutAy
            Else:
            d.Add KeyIn, r 'r is set as the item value referencing the row of the OutAy when it was first added. The reference is used when .Exists is true
            For c = 1 To 4
                OutAy(r, c) = InAy(i, c)
            Next c
            r = r + 1
        End If
    Next
    RemoveDupes = OutAy
End Function

 

[zensathish]

Hi Mick,

You code is very useful.

I need one more help. My data is as below and i am trying to get the output as mentioned. your code partially works. I would highly appreciate if you can help with the code.

Input
NUMBER NAME CODE HOURS
1 John Smith 410 8
1 John Smith 411 6
1 John Smith 410 8
2 Jane Smith 410 7
2 Jane Smith 411 7
2 Jane Smith 410 6.5
2 Jane Smith 411 6.5

Expected output

NUMBER NAME CODE HOURS
1 John Smith 410 16
1 John Smith 411 6
2 Jane Smith 410 13.5
2 Jane Smith 411 13.5

Regards,
Zen