Locate duplicates and sum the two columns with different values

[ajcarlos18]

Hi,

Need help to add / alter the code. Need to sum the values on column 4 & 5 by locating duplication on column 1. Say for an example:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Consumables[/TD]
[TD]31222[/TD]
[TD]NY[/TD]
[TD][TABLE="width: 167"]
<tbody>[TR]
[TD]698.2[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD]77.6[/TD]
[/TR]
[TR]
[TD]Consumables[/TD]
[TD]31222[/TD]
[TD]NY[/TD]
[TD]123.4[/TD]
[TD]445.9[/TD]
[/TR]
[TR]
[TD]Consumables[/TD]
[TD]31222[/TD]
[TD]NY[/TD]
[TD]554.21[/TD]
[TD]23.5[/TD]
[/TR]
[TR]
[TD]Spares[/TD]
[TD]31119[/TD]
[TD]NY[/TD]
[TD]33.4[/TD]
[TD]87.0[/TD]
[/TR]
[TR]
[TD]Spares[/TD]
[TD]31119[/TD]
[TD]NY[/TD]
[TD]55.7[/TD]
[TD]23.9[/TD]
[/TR]
</tbody>[/TABLE]

Output:

[TABLE="width: 500"]
<tbody>[TR]
[TD]Consumables[/TD]
[TD]31222[/TD]
[TD]NY[/TD]
[TD]1375.81[/TD]
[TD]547[/TD]
[/TR]
[TR]
[TD]Spares[/TD]
[TD]31119[/TD]
[TD]NY[/TD]
[TD]89.1[/TD]
[TD]110.9[/TD]
[/TR]
</tbody>[/TABLE]



Code:

Sub Finaladd()


Dim Rng As Range, Dn As Range, n As Long, nRng As Range


Sheet17.Select
Sheet17.Range("A1").Select


Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
With CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare


Sheet17.Select
Sheet17.Range("A1").Select


For Each Dn In Rng
If Not .Exists(Dn.Value) Then
.Add Dn.Value, Dn
Else
If nRng Is Nothing Then Set nRng = _
Dn Else Set nRng = Union(nRng, Dn)
.Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
End If
Next
If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With

Thank you very much for your help

 

[nemmi69]

I am not sure I see the problem as this works

Sub Finaladd()
Dim Rng As Range, Dn As Range, n As Long, nRng As Range
Dim NewID As Boolean


Set Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))


With CreateObject("scripting.dictionary")
    .CompareMode = vbTextCompare
    
    For Each Dn In Rng
        If Not .Exists(Dn.Value) Then
            .Add Dn.Value, Dn
        Else
            If nRng Is Nothing Then Set nRng = _
            Dn Else Set nRng = Union(nRng, Dn)
            .Item(Dn.Value).Offset(, 3) = .Item(Dn.Value).Offset(, 3) + Dn.Offset(, 3)
        End If
    Next
    If Not nRng Is Nothing Then nRng.EntireRow.Delete
End With
End Sub

 

[ajcarlos18]

Thanks for the reply. The code sums up column D only. What I need is for both column D & E to be summed up. Maybe I lack the code to include column E in the summation.

 

[nemmi69]

You could try

Sub FinalAdd2()
Dim Ast As Long, AEnd As Long, Bst As Long, BEnd As Long
Dim ACnt As Long, BCnt As ILong


Ast = 2
AEnd = Range("A1048576").End(xlUp).Row
ACnt = Ast
BCnt = Ast + 1




Do While ACnt <= AEnd
    Do While BCnt <= AEnd
        If Range("A" & ACnt).Value = Range("A" & BCnt).Value Then
            Range("D" & ACnt).Value = Range("D" & ACnt).Value + Range("D" & BCnt).Value
            Range("E" & ACnt).Value = Range("E" & ACnt).Value + Range("E" & BCnt).Value
            Rows(BCnt & ":" & BCnt).Delete xlShiftUp
            AEnd = AEnd - 1
        Else
            BCnt = BCnt + 1
        End If
    Loop
    ACnt = ACnt + 1
    BCnt = ACnt + 1
Loop
End Sub

 

[ajcarlos18]

Wow it worked. Thank you very much nemmi69 . Kudos