Find Duplicate Values, Sum Amount, Keep Most recent Row

kentster

New Member
Joined
Nov 22, 2016
Messages
28
Hi - I am using Excel 2013. I have tried Consolidated Data but it just adds the dates.

I have created the "Beginning" and "End" tables below as an example. Is it possible to have a VBA code that accomplishes this? Starting with the Beginning table, find the duplicated values in Column 1. From there, add the values in Column 3 for those duplicate rows. Then find the row from those duplicate rows which has the most recent date and keep that row.

The end result is the End table. One row for each of the duplicates which has the summed value, and the most recent date (all other data would simply flow from the row selected with the most recent date). I hope that made sense.

See Below:

Beginning
Opp+Lvl6SaaS Opp #AmountLevel 6Level 7Is it in SW FcstDate Updated
A1A101AY1/3/2016
B1B201AY5/1/2016
B1C301AY10/5/2016
C2C102AY11/1/2016
A1A1001AY5/5/2015
D1D101AY11/1/2016

<tbody>
</tbody>


End result after Macro
Opp+Lvl6SaaS Opp #AmountLevel 6Level 7Is it in SW FcstDate Updated
A1A1101AY1/3/2016
B1C501AY10/5/2016
C2C102AY11/1/2016
D1D101AY11/1/2016

<tbody>
</tbody>


I appreciate everyone's assistance here. I will keep trying with the hopes this can be figured out.
 

Excel Facts

Why does 9 mean SUM in SUBTOTAL?
It is because Sum is the 9th alphabetically in Average, Count, CountA, Max, Min, Product, StDev.S, StDev.P, Sum, VAR.S, VAR.P.

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
Give this a try on a copy of your file.

Code:
Sub t()
Dim i As Long, lr As Long, fn As Range, fAdr As String
With ActiveSheet
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 3 Step -1
        If Application.CountIf(.Range("A:A"), .Cells(i, 1).Value) > 1 Then
            Set fn = .Range("A1:A" & i).Find(.Cells(i, 1).Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    fAdr = fn.Address
                    Do
                        fn.Offset(, 2) = fn.Offset(, 2).Value + .Cells(i, 3).Value
                        If fn.Offset(, 6).Value < .Cells(i, 7).Value Then
                            fn.Offset(, 6) = .Cells(i, 7).Value
                        End If
                        Set fn = .Range("A2:A" & i).FindNext(fn)
                    Loop While fn.Address <> fAdr
                    Rows(i).Delete
                End If
        End If
    Next
End With
End Sub
 

kentster

New Member
Joined
Nov 22, 2016
Messages
28
Hi - Thanks. One little snag it appears. I tried it out on my data below, and it looks like it is adding D2+D3+D4 for the duplicate value of XXX1, instead of D2+D4+D7. The sum of the values for A1 duplicates is showing 220 with the code you had provided when it should be 210. It was correct for BBB2. I tried a sort in the code before I ran your code, but it was the same result. Below is a snapshot of how my data could look before running the macro.

RowBCDEFGH
2XXX1XXX1001AA10/5/2016
3B1B201A-5/1/2016
4XXX1XXX1001AA11/1/2016
5C3C203AA7/5/2016
6C4C304AA8/15/2016
7XXX1XXX101AA9/3/2016
8D2D202AA9/23/2016
9F1F101AA3/4/2016
10BBB2BBB502AA10/5/2016
11BBB2BBB102AA10/7/2016
12G1G201A-11/23/2016
13H2H102A-12/1/2016
14I1I201A-8/5/2016

<colgroup><col span="7"><col></colgroup><tbody>
</tbody>



I appreciate the assist!
 

MickG

MrExcel MVP
Joined
Jan 9, 2008
Messages
14,841
Possibly, another option:-
Code:
[COLOR="Navy"]Sub[/COLOR] MG05Dec13
[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] Q [COLOR="Navy"]As[/COLOR] Variant, DK [COLOR="Navy"]As[/COLOR] Variant, nRng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & 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] Dn.Offset(, 6).Value > .Item(Dn.Value).Offset(, 6).Value [COLOR="Navy"]Then[/COLOR]
            [COLOR="Navy"]Set[/COLOR] .Item(Dn.Value) = Dn
        [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Item(Dn.Value).Address = Dn.Address [COLOR="Navy"]Then[/COLOR]
        .Item(Dn.Value).Offset(, 2).Value = .Item(Dn.Value).Offset(, 2).Value + Dn.Offset(, 2).Value
        [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)
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]
Regards Mick
 

kentster

New Member
Joined
Nov 22, 2016
Messages
28
EUREKA! I messed around with multiple examples whic had significant rows of data and I just modified your code to find the right columns and all worked out perfectly! Awesome stuff! Thank you so much!
 

JLGWhiz

Well-known Member
Joined
Feb 7, 2012
Messages
12,979
Office Version
  1. 2013
Platform
  1. Windows
EUREKA! I messed around with multiple examples whic had significant rows of data and I just modified your code to find the right columns and all worked out perfectly! Awesome stuff! Thank you so much!

here is what I finally arrived at.

Code:
Sub t()
Dim i As Long, lr As Long, fn As Range, fAdr As String, dRw As Long
With ActiveSheet
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 3 Step -1
        If Application.CountIf(.Range("A:A"), .Cells(i, 1).Value) > 1 Then
            Set fn = .Range("A1:A" & i).Find(.Cells(i, 1).Value, , xlValues, xlWhole)
                If Not fn Is Nothing Then
                    fAdr = fn.Address
                    Do
                        If fn.Address = fAdr Then
                            Range(fAdr).Offset(, 2) = fn.Offset(, 2).Value + .Cells(i, 3).Value
                                If fn.Offset(, 6).Value < .Cells(i, 7).Value Then
                                    Range(fAdr).Offset(, 6) = Cells(i, 7).Value
                                End If
                            Rows(i).Delete
                        Else
                            Range(fAdr).Offset(, 2) = Range(fAdr).Offset(, 2).Value + fn.Offset(, 2).Value
                                If Range(fAdr).Offset(, 6).Value < fn.Offset(, 6).Value Then
                                    Range(fAdr).Offset(, 6) = fn.Offset(, 6).Value
                                End If
                                dRw = fn.Row
                        End If
                        Set fn = .Range("A2:A" & i - 1).FindNext(fn)
                        If Not IsEmpty(dRw) Then
                            .Rows(dRw).Delete
                            dRw = Empty
                        End If
                    Loop While fn.Address <> fAdr
                End If
        End If
    Next
End With
End Sub
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,130,167
Messages
5,640,533
Members
417,151
Latest member
ChickenTenderer

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
Top