Find Duplicate Values, Sum Amount, Keep Most recent Row

[kentster]

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+Lvl6	SaaS Opp #	Amount	Level 6	Level 7	Is it in SW Fcst	Date Updated
A1	A	10	1	A	Y	1/3/2016
B1	B	20	1	A	Y	5/1/2016
B1	C	30	1	A	Y	10/5/2016
C2	C	10	2	A	Y	11/1/2016
A1	A	100	1	A	Y	5/5/2015
D1	D	10	1	A	Y	11/1/2016

<tbody>
</tbody>

End result after Macro
Opp+Lvl6	SaaS Opp #	Amount	Level 6	Level 7	Is it in SW Fcst	Date Updated
A1	A	110	1	A	Y	1/3/2016
B1	C	50	1	A	Y	10/5/2016
C2	C	10	2	A	Y	11/1/2016
D1	D	10	1	A	Y	11/1/2016

<tbody>
</tbody>

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

 

[JLGWhiz]

Give this a try on a copy of your file.

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]

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.

Row	B	C	D	E	F	G	H
2	XXX1	XXX	100	1	A	A	10/5/2016
3	B1	B	20	1	A	-	5/1/2016
4	XXX1	XXX	100	1	A	A	11/1/2016
5	C3	C	20	3	A	A	7/5/2016
6	C4	C	30	4	A	A	8/15/2016
7	XXX1	XXX	10	1	A	A	9/3/2016
8	D2	D	20	2	A	A	9/23/2016
9	F1	F	10	1	A	A	3/4/2016
10	BBB2	BBB	50	2	A	A	10/5/2016
11	BBB2	BBB	10	2	A	A	10/7/2016
12	G1	G	20	1	A	-	11/23/2016
13	H2	H	10	2	A	-	12/1/2016
14	I1	I	20	1	A	-	8/5/2016

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

I appreciate the assist!

 

[MickG]

Possibly, another option:-

[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]

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]

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.

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