Removing Duplicates & Summing Quantity

[Chris]

Hi Experts

I have been working on making this small procedure. It
seems to work fine most of the time but very slow.
This is what it was intended to do
- Column A have list of Skus/Part# (could be upto 4000)
starting Row 2 (row 1 is a header)
- Col B is Quantity
- When the procedure is called it asks user if they would
like to Add up the quantity of duplicate skus. If yes is
selecetd it does so & advise by placing a comment in Col C
about how many times a particular Part# was duplicated
(one skus could be duplicated unlimited times)

What I would like your advise on is it seems to work fine
but ocasionally I have noticed it may not detect a
duplicate part (specially in very large data).
Also it seems bit slow & I am sure you may have a total
different and effecient aproach to this.
Also is there a way to actually put the result on a brand
new sheet created on fly.
I thought arrays could work faster but I dont have enough
have no knoledge on how to build it.

Thanks in advance for all your help
I use XL 2003 on Win2k


Sub RemoveDuplicates()
Call CheckL
Dim AddQty As Boolean
Dim DupeCounter
Dim FoundDupe As Boolean

Dim Response As Long
Response = MsgBox("Would You Like to Sum Up Quantities
for Duplicate Part#", vbYesNoCancel +
vbQuestion, "Duplicate Remover")
Select Case Response
Case 6 'User has clicked Yes
AddQty = True
Cells(1, 3).Value = "Qty Summed"
Case 7 'User has clicked No
AddQty = False
Cells(1, 3).Value = "Qty Not Summed"
Case 2 'User has clicked Cancel
Exit Sub

End Select
Application.ScreenUpdating = False
' log it
LogInfo ("Remove Duplicates," & vLastRow())
FoundDupe = False
For i = 2 To vLastRow()
PartNo = Cells(i, 1).Value
DupeCounter = 1
For j = i + 1 To vLastRow()
If PartNo = Cells(j, 1).Value Then
FoundDupe = True
' add up qty
If AddQty Then
Cells(i, 2).Value = Cells(i, 2).Value
+ Cells(j, 2).Value
End If
Cells(j, 1).Value = ""
Cells(j, 2).Value = ""
DupeCounter = DupeCounter + 1
End If
Next j
' advise user if duplicated

If DupeCounter > 1 Then
Cells(i, 3).Value = "Duplicated x " &
DupeCounter
Else
Cells(i, 3).Value = ""
End If
Next i
' clean up loop to clear 0 values in qty
If AddQty Then
For i = 2 To vLastRow()
If Cells(i, 1).Value = "" Then
Cells(i, 2).Value = ""
Cells(i, 3).Value = ""
End If

Next i
End If
If FoundDupe Then
MsgBox "Duplicates Found" & vbCrLf & "Duplicates
Removed" & vbCrLf & vbCrLf & "(You May Need to Delete
Blank Rows Using DeW)" & vbCrLf, vbOKOnly + vbInformation
Else

MsgBox "No Duplicates Found", vbOKOnly +
vbInformation
Cells(1, 3).Value = ""
End If
Application.ScreenUpdating = True
End Sub

 

[Guest]

There was a similar question I answered before - can you
sort the data and if the line above is the same part than
add otherwise display total so far.
this can be done in a new column as a formula rather than
a macro/VBA

 

[Cecilkumara Fernando]

Chris,
try these macros in a new sheet with your data copied to colA and B

Sub Macro1()
Application.ScreenUpdating = False
'Range("E1") = Now()
Range("A1:A6001").AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Range("C1"), Unique:=True
LastRw = Range("C" & Rows.Count).End(xlUp).Row
With Range("D2")
..Formula = _
"=SUMPRODUCT(($A$2:$A$6001=C2)*($B$2:$B$6001))"
..AutoFill Destination:=Range("D2" & LastRw)
End With
'Range("F1") = Now()
Application.ScreenUpdating = True
End Sub

This one is faster but it sorts the list

Sub Macro3()
'Range("E1") = Now() 'only to get the start time
LastRw = Range("A" & Rows.Count).End(xlUp).Row
Range("A1:B" & LastRw).Select
Selection.Sort Key1:=Range("A2"), _
Order1:=xlAscending, Header:=xlYes, _
OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom
Range("C2").Select
With Range("C2")
..Formula = "=IF(A2=A1,B2+C1,B2)"
..AutoFill Destination:=Range("C2:C" & LastRw)
End With
Range("D2").Select
With Range("D2")
..Formula = "=IF(A2=A3,"""",A2)"
..AutoFill Destination:=Range("D2" & LastRw)
End With
Range("C2" & LastRw).Copy
Range("C2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("D2" & LastRw).Select
Selection.SpecialCells(xlCellTypeConstants, 2).Select
Selection.EntireRow.Delete
'Range("F1") = Now() 'to get the end time
End Sub

 

[Chris]

Thanks a lot, I tried the 1st Macro & it worked great & of
course fast.
Thanks again