Find duplicates, sum and delete dups

[John]

I found programming that finds duplicates and sums up the dups but now I need
to delete the duplicate records. After running this code, I end up with 709
in row 4 that shows as 250 which is what I want but rows 2 and 3 needs
deleted.

COL-A COL-B COL-C COL-D
1239 14 COMPUTER HARDWARE 0
1250 10 COURSES - TRAINING 417
1250 12 COURSES - TRAINING 42
1250 14 COURSES - TRAINING 250
1271 10 CUST. DUTY & NON-RECOV 8333

This is what I have:
Sub Test()
Dim iLastRow As Long
Dim i As Long
iLastRow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 2 To iLastRow
If Cells(i, "A").Value = Cells(i - 1, "A").Value Then
If Cells(i, "A").Value <> Cells(i + 1, "A").Value Then
Cells(i, "E").Value = Application.SumIf( _
Columns(1), Cells(i, "A").Value, Columns(4))
End If
End If
Next i
End Sub

This is what I need to end up with:
COL-A COL-B COL-C COL-D
1239 14 COMPUTER HARDWARE 0
1250 14 COURSES - TRAINING 709
1271 10 CUST. DUTY & NON-RECOV 8333

Can someone help to complete this? Thanks,

 

[marcus]

Hi John

This should do the trick for you. It looks for duplicates in Col A and

sums column D, producing just the summary data. It assumes the data in

column A is sorted.

A pivot table would work just as well.



Sub SumandDelete1()

Dim myloop As Double
Dim myMatched As String
Dim SubTtl As Double
Dim RowCount As Double

Application.ScreenUpdating = False
Application.DisplayAlerts = False
SubTtl = 0

RowCount = Range("A65536").End(xlUp).Row

For myloop = RowCount To 2 Step -1
SubTtl = Cells(myloop, "D")
If Cells(myloop, "A") = Cells(myloop - 1, "A") Then
SubTtl = SubTtl + Cells(myloop - 1, "D")
myMatched = "Y"
Rows(myloop).Delete
End If

If myMatched = "Y" Then
Cells(myloop - 1, "D") = SubTtl
myMatched = "N"
SubTtl = 0
End If
Next myloop

Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub

Regards

Marcus

 

[John]

Hey Marcus,
Thanks for the info. Once I did sort the data, the programming worked
excellant. That was my original problem, the sorting of the data.

Thanks again,