Samir has attended:
Excel VBA Intro Intermediate course
Summing duplicates
Hi there - i have been struggling to find a way to do this. I have a list of say 100 rows and say 1 column of data. In the rows are names in column 1 and in column 2 and the amount purchased of this company. What i have however is duplicates so i might have Company ABC twice, with two lots of different weights, 20% and 10%. What i need as a finished product is the sheet to find all duplicates and sum them together and then remove one duplicate. Any thoughts on how i could do this?
RE: summing duplicates
Hello Samir,
The following code will perform what I think you need, it will need adjusting to suit your sheet layout, and you may need to have a And/OR within your IF statements if you need to compare more than one cell for duplicate.
The code sorts the column A into ascending order. Then starting at the bottom it moves upwards one row at a time checking for duplicates and adding a value in the B column.
Sub test()
Dim StoreNumber As Integer
Dim Length As Integer
Length = Range("A1").CurrentRegion.Rows.Count
Range("A1").Select
Selection.Sort Key1:=Range("a1"), Order1:=xlAscending
Selection.End(xlDown).Select
Do Until Length < 2
If ActiveCell = ActiveCell.Offset(-1, 0).Value Then
StoreNumber = ActiveCell.Offset(-1, 1).Value
ActiveCell.Offset(-1, 1).Value = StoreNumber + ActiveCell.Offset(0, 1)
ActiveCell.EntireRow.Delete
ActiveCell.Offset(-1, 0).Select
Else
ActiveCell.Offset(-1, 0).Select
End If
Length = Length - 1
Loop
End Sub
I hope this resolves your question. If it has, please mark this question as resolved.
If you require further assistance, please reply to this post. Or perhaps you have another Microsoft Office question?
Have a great day.
Regards,
Mark
Microsoft Office Specialist Trainer
RE: summing duplicates
Many thanks Mark this does the trick. I do have another somewhat linked question. I have data going down 100 rows and about 20 columns across. However i need to delete some based on a condition. The condition is that if certain words are in column C i want the row to be deleted and in addition if column D is blank then the row should also be deleted. I wrote the below for the first part to remove based on words but that doesnt seem to be working:
ub Delete_Based_on_Criteria()
Dim X As Long
Dim Z As Long
Dim LastRow As Long
Dim FoundRowToDelete As Boolean
Dim OriginalCalculationMode As Long
Dim RowsToDelete As Range
Dim SearchItems() As String
Dim DataStartRow As Long
Dim SearchColumn As String
Dim SheetName As String
DataStartRow = 9
SearchColumn = "C"
SheetName = "Book1"
SearchItems = Split("FORWARD, SPOT, private eqty")
On Error GoTo Whoops
OriginalCalculationMode = Application.Calculation
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
With Worksheets(Book1)
LastRow = .Cells(.Rows.Count, SearchColumn).End(xlUp).Row
For X = LastRow To DataStartRow Step -1
FoundRowToDelete = False
For Z = 0 To UBound(SearchItems)
If InStr(.Cells(X, SearchColumn).Value, SearchItems(Z)) Then
FoundRowToDelete = True
Exit For
End If
Next
If FoundRowToDelete Then
If RowsToDelete Is Nothing Then
Set RowsToDelete = .Cells(X, SearchColumn)
Else
Set RowsToDelete = Union(RowsToDelete, .Cells(X, SearchColumn))
End If
If RowsToDelete.Areas.Count > 100 Then
RowsToDelete.EntireRow.Delete
Set RowsToDelete = Nothing
End If
End If
Next
End With
If Not RowsToDelete Is Nothing Then
RowsToDelete.EntireRow.Delete
End If
Whoops:
Application.Calculation = OriginalCalculationMode
Application.ScreenUpdating = True
End Sub
