Search Column - Find Multiple Entries - Sum Then Delete to Single Entry

[Ledge]

Hi Folks, Hoping I could get some guidance with this:

I have 3 columns of data on sheet1.

Column A is numerical "APN"
Column B is text "Product Description"
Column C is numerical "Total"

Is there a way to search column A for multiple matching entries and if
so to sum the total while reducing back to one entry?

EG: SHEET CURRENTLY LOOKS LIKE THIS

APN Product Description Total
25454 AAA 2
32121 BBB 1
32654 CCC 2
25454 AAA 5

WOULD LIKE IT TO DO THIS

APN Product Description Total
25454 AAA 7
32121 BBB 1
32654 CCC 2

The code below detects the multiple entries in Column A but I need to
then Sum the values in Column C then delete/hide thus reducing the
multiple entries back to a single entry.

This one is beyond my skills and would appreciate any assistance.

Hope this makes sense

Thanks for your time.

Dean


Sub Macro2()

Dim wks As Worksheet
Dim rng As Range

Set wks = ActiveSheet
Set rng = wks.Cells

rng.Sort Key1:=wks.Range("A1"), Order1:=xlAscending, Header:=xlNo
Set rng = wks.Range("A65535").End(xlUp)
Do While rng.Row > 1
Set rng = rng.Offset(-1, 0)
If rng.Offset(1, 0).Value = rng.Value Then ????????????????

Loop
Set wks = Nothings
Set rng = Nothing

End Sub

 

[Guest]

Why not just use a pivot table? It will do all of that for you and more...

 

[Ledge]

I require that it be sorted in its current format. No headers etc

 

[Guest]

Hi Dean,
Try this code. It should sum the dupes, delete the extras, and then re-sort
the data into the original order.

Sub Consolidate()

Dim Sorter As Double
Dim Iloop As Double
Dim Matched As String
Dim SubTtl As Double
Dim RowCount As Double

'Turn off warnings, etc.
Application.ScreenUpdating = False
Application.DisplayAlerts = False
SubTtl = 0
Sorter = 0

'Assign numbers to retain original order.
RowCount = Range("A65536").End(xlUp).Row
For Iloop = 2 To RowCount
Cells(Iloop, "D") = Sorter
Sorter = Sorter + 1
Next Iloop

'Sort worksheet.
Range("A1" & RowCount).Select
Selection.Sort Key1:=Range("A1"), Order1:=xlAscending, _
Key2:=Range("B1"), Order2:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom

For Iloop = RowCount To 2 Step -1
SubTtl = Cells(Iloop, "C")
If Cells(Iloop, "A") & Cells(Iloop, "B") = Cells(Iloop - 1, "A") & _
Cells(Iloop - 1, "B") Then
SubTtl = SubTtl + Cells(Iloop - 1, "C")
Matched = "Y"
Rows(Iloop).Delete
End If
If Matched = "Y" Then
Cells(Iloop - 1, "C") = SubTtl
Matched = "N"
SubTtl = 0
End If
Next Iloop

'Re-sort worksheet to original order.
Range("A1" & RowCount).Select
Selection.Sort Key1:=Range("D1"), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, MatchCase:=False,
Orientation:=xlTopToBottom
Columns("D").Delete
Range("A1").Select

'Turn on warnings, etc.
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

 

[Ledge]

Ken, Thank you so very much.. code worked perfectly.

 

[Guest]

This looks like it could also be the answer to my problem - but I'm just
finding out about Macros - would I need to modify this code to have it work
on a 16 column sheet, accumulating totals for 12 cols. and then deleting the
duplicates?