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..

NUMBERNAMECODEHOURS
1John Smith4108
1John Smith4106
1John Smith4108
2Jane Smith4107
2Jane Smith4107
2Jane Smith4106.5
2Jane Smith4106.5

<tbody>
</tbody>

To turn into this..

NUMBERNAMECODEHOURS
1John Smith41022
2Jane Smith41027

<tbody>
</tbody>


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

Fastest way to copy a worksheet?
Hold down the Ctrl key while dragging tab for Sheet1 to the right. Excel will make a copy of the worksheet.
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.
200020012008200020152016201420172001201819881785… …
2108434681231315… …
To consolidate and sort them horizontally from cell I2



<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>
 
Upvote 0
IKLMNOPQRSTUVWX
1
2200020012008200020152016201420172001201819881785… …
32108434681231315… …
4To consolidate and sort them horizontally from cell I2

<colgroup><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col><col></colgroup><tbody>
</tbody>
 
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
245
airforceone
airforceone
H
  • Solved
Merging Duplicate Rows and time entries
Replies
5
Views
257
alansidman
A
M
  • Question
select value two columns to the left of variable in an array
Replies
1
Views
241
myall_blues
myall_blues
J
  • Solved
VBA to merge duplicate rows and sum values in certain column with adjustments
Replies
9
Views
742
Alex Blakenburg
A
A
  • Solved
adapting code to merge amount for duplicates item on usrform
Replies
4
Views
287
abdo meghari
A

Forum statistics

Threads
1,221,526
Messages
6,160,340
Members
451,637
Latest member
hvp2262

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