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

 

[MickG]

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

 

[JackDanIce]

Welcome to the board. This will output the aggregated table under the original:

Sub CombineDupes()
    
    Dim x       As Long
    Dim r       As Long
    Dim arr()   As Variant
    Dim dic     As Object
    Const DELIM As String = "|"
    
    Set dic = CreateObject("Scripting.Dictionary")
    
    x = Cells(Rows.Count, 1).End(xlUp).row
    arr = Cells(1, 1).Resize(x, 4).Value
    
    For x = LBound(arr, 1) + 1 To UBound(arr, 1)
        If dic.exists(arr(x, 1)) Then
            arr(x, 4) = arr(x, 4) + CDbl(Split(dic(arr(x, 1)), DELIM)(2))
        Else
            dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4)
        End If
        dic(arr(x, 1)) = arr(x, 2) & DELIM & arr(x, 3) & DELIM & arr(x, 4)
    Next x
    
    r = UBound(arr, 1) + 2
    
    Application.ScreenUpdating = False
    
    Cells(r, 1).Resize(, 4).Value = Cells(1, 1).Resize(, 4).Value
    r = r + 1
    
     For x = 0 To dic.Count - 1
        Cells(r + x, 1).Value = dic.keys()(x)
        Cells(r + x, 2).Resize(, 3).Value = Split(dic.items()(x), DELIM)
        Cells(r + x, 4).Value = CDbl(Cells(r, 4).Value)
    Next x
    
    Application.ScreenUpdating = True
    
    Erase arr
    Set dic = Nothing
    
End Sub

 

[aydinrotar]

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

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

Regards Aydin

 

[aydinrotar]

Thanks for the reply mate, I actually just needed the original table be altered. But nonetheless, thanks for your help

 

[JackDanIce]

No trouble, glad it's resolved

 

[MickG]

You're welcome

 

[darrenliux]

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
I found your code is very useful for my project, thank you.
Is it possible not to delete the entire row after the execution? (maybe just clear the content instead).

 

[MickG]

Try changing the last line as below:-

[COLOR=#000080]If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] nRng.EntireRow.Clearcontents

 

[darrenliux]

Try changing the last line as below:-

[COLOR=#000080]If[/COLOR] Not nRng [COLOR=navy]Is[/COLOR] Nothing [COLOR=navy]Then[/COLOR] nRng.EntireRow.Clearcontents

Hi MickG
Thank you for your reply.
I’ve tried it. but it doesn’t work the way I want it to.
I’d like it doesn’t clear the contents of the entire row, but only those within these columns, and it should also sort the data by column 1.
Hope that you can help. Thank you again.