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

Enter current date or time
Ctrl+: enters current time. Ctrl+; enters current date. Use Ctrl+: Ctrl+; Enter for current date & time.
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
357
airforceone
airforceone
H
  • Solved
Merging Duplicate Rows and time entries
Replies
5
Views
294
alansidman
A
montecarlo2012
  • Question Question
change display from horizontal to vertical
Replies
2
Views
101
montecarlo2012
montecarlo2012
M
  • Question Question
select value two columns to the left of variable in an array
Replies
1
Views
274
myall_blues
myall_blues
J
  • Solved
VBA to merge duplicate rows and sum values in certain column with adjustments
Replies
9
Views
875
Alex Blakenburg
A

Forum statistics

Threads
1,223,911
Messages
6,175,326
Members
452,635
Latest member
laura12345

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