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

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

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

Jim Thomlinson


"Ledge" wrote:

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

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

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:D" & 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:D" & 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
--
Ken Hudson


"Ledge" wrote:

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

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

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?
--
Mike Watkins


"Ken Hudson" wrote:

> 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:D" & 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:D" & 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
> --
> Ken Hudson
>
>
> "Ledge" wrote:
>
> > 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
> >
> >