VBA to merge duplicate rows and sum values in certain column

A

aydinrotar

New Member
Joined
Jul 11, 2017
Messages
10
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:

Code: 
[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
 
Sort by date Sort by votes
Try this:-
Code: 
[COLOR="Navy"]Sub[/COLOR] MG14May26
[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, nCol [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
nCol = ActiveSheet.Cells(1).CurrentRegion.Columns.Count
[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"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] nRng
    Dn.Resize(, nCol).ClearContents
[COLOR="Navy"]Next[/COLOR] Dn
Rng.Resize(, nCol).Sort Key1:=Range("A2"), Order1:=xlAscending
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 
Upvote 0

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.
Hi Mick
This works perfectly. Thanks a lot.

Would you mind have a look at this one, it is fair similar, just the data need to be sorted is horizontal. Much appreciated.
[TABLE="width: 1404"]
<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD] [TABLE="width: 990"]
<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD]2000[/TD]
[TD]2001[/TD]
[TD]2008[/TD]
[TD]2000[/TD]
[TD]2015[/TD]
[TD]2016[/TD]
[TD]2014[/TD]
[TD]2017[/TD]
[TD]2001[/TD]
[TD]2018[/TD]
[TD]1988[/TD]
[TD]1785[/TD]
[TD]… …[/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]10[/TD]
[TD]8[/TD]
[TD]4[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]6[/TD]
[TD]8[/TD]
[TD]12[/TD]
[TD]3[/TD]
[TD]13[/TD]
[TD]15[/TD]
[TD]… …[/TD]
[/TR]
[TR]
[TD="colspan: 13"]To consolidate and sort them horizontally from cell I2


[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
[TABLE="width: 1195"]
<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>[TR]
[TD][/TD]
[TD]I[/TD]
[TD]K[/TD]
[TD]L[/TD]
[TD]M[/TD]
[TD]N[/TD]
[TD]O[/TD]
[TD]P[/TD]
[TD]Q[/TD]
[TD]R[/TD]
[TD]S[/TD]
[TD]T[/TD]
[TD]U[/TD]
[TD]V[/TD]
[TD]W[/TD]
[TD]X[/TD]
[/TR]
[TR]
[TD]1[/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]2[/TD]
[TD]2000[/TD]
[TD]2001[/TD]
[TD]2008[/TD]
[TD]2000[/TD]
[TD]2015[/TD]
[TD]2016[/TD]
[TD]2014[/TD]
[TD]2017[/TD]
[TD]2001[/TD]
[TD]2018[/TD]
[TD]1988[/TD]
[TD]1785[/TD]
[TD]… …[/TD]
[TD] [/TD]
[TD] [/TD]
[/TR]
[TR]
[TD]3[/TD]
[TD]2[/TD]
[TD]10[/TD]
[TD]8[/TD]
[TD]4[/TD]
[TD]3[/TD]
[TD]4[/TD]
[TD]6[/TD]
[TD]8[/TD]
[TD]12[/TD]
[TD]3[/TD]
[TD]13[/TD]
[TD]15[/TD]
[TD]… …[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4[/TD]
[TD="colspan: 13"]To consolidate and sort them horizontally from cell I2[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]
 
Upvote 0
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG14May59
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, nRng [COLOR=navy]As[/COLOR] Range
 [COLOR=navy]Set[/COLOR] Rng = Range(Range("I2"), Cells(2, Columns.Count).End(xlToLeft))
    [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(1) = .Item(Dn.Value).Offset(1) + Dn.Offset(1)
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] nRng
    Dn.Resize(2).ClearContents
[COLOR=navy]Next[/COLOR] Dn
Rng.Resize(2).Sort Key1:=Range("I2"), Orientation:=xlLeftToRight  
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
 
Last edited:
Upvote 0
MickG said:
Try this:-
Code: 
[COLOR=navy]Sub[/COLOR] MG14May59
[COLOR=navy]Dim[/COLOR] Rng [COLOR=navy]As[/COLOR] Range, Dn [COLOR=navy]As[/COLOR] Range, nRng [COLOR=navy]As[/COLOR] Range
 [COLOR=navy]Set[/COLOR] Rng = Range(Range("I2"), Cells(2, Columns.Count).End(xlToLeft))
    [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(1) = .Item(Dn.Value).Offset(1) + Dn.Offset(1)
    [COLOR=navy]End[/COLOR] If
[COLOR=navy]Next[/COLOR]
[COLOR=navy]For[/COLOR] [COLOR=navy]Each[/COLOR] Dn [COLOR=navy]In[/COLOR] nRng
    Dn.Resize(2).ClearContents
[COLOR=navy]Next[/COLOR] Dn
Rng.Resize(2).Sort Key1:=Range("I2"), Orientation:=xlLeftToRight  
[COLOR=navy]End[/COLOR] [COLOR=navy]With[/COLOR]
[COLOR=navy]End[/COLOR] [COLOR=navy]Sub[/COLOR]
Regards Mick
Click to expand...

Hi Mick
Just one more thing. Is it possible that if there are no duplicated data in the top row, instead of rendering a 'debug' prompt, it just sort the data?
Kind regards
 
Upvote 0
Add lines in Red:-
Code: 
[B][COLOR=#FF0000]If Not nRng Is Nothing Then[/COLOR][/B]
    For Each Dn In nRng
        Dn.Resize(2).ClearContents
    Next Dn
[B][COLOR=#FF0000]End If[/COLOR][/B]
 
Upvote 0
Hi @MickG, can you explain what each of these lines do in the code? I am working on a similar project with only exception that I have two sets of tables to find duplicates in.
 
Upvote 0
You must log in or register to reply here.

Similar threads

airforceone
  • Solved
Populate Rows & Columns by Comma Split
2
Replies
12
Views
363
airforceone
airforceone
H
  • Solved
Merging Duplicate Rows and time entries
Replies
5
Views
297
alansidman
alansidman
montecarlo2012
  • Question Question
change display from horizontal to vertical
Replies
2
Views
137
montecarlo2012
montecarlo2012
M
  • Question Question
select value two columns to the left of variable in an array
Replies
1
Views
279
myall_blues
myall_blues
J
  • Solved
VBA to merge duplicate rows and sum values in certain column with adjustments
Replies
9
Views
958
Alex Blakenburg
A

Forum statistics

Threads
1,224,823
Messages
6,181,181
Members
453,022
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top