Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Removing Duplicates & Summing Quantity
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 244
Default Removing Duplicates & Summing Quantity
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
Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
No Name
 
Posts: n/a
Default Removing Duplicates & Summing Quantity
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

-----Original Message-----
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
.

Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 46
Default Removing Duplicates & Summing Quantity
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:D" & 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:D" & LastRw)
End With
Range("C2:D" & LastRw).Copy
Range("C2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("D2:D" & LastRw).Select
Selection.SpecialCells(xlCellTypeConstants, 2).Select
Selection.EntireRow.Delete
'Range("F1") = Now() 'to get the end time
End Sub

"Chris" wrote in message
...
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


Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 244
Default Removing Duplicates & Summing Quantity
Thanks a lot, I tried the 1st Macro & it worked great & of
course fast.
Thanks again
-----Original Message-----
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:D" & 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:D" & LastRw)
End With
Range("C2:D" & LastRw).Copy
Range("C2").PasteSpecial Paste:=xlPasteValues, _
Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Range("D2:D" & LastRw).Select
Selection.SpecialCells(xlCellTypeConstants, 2).Select
Selection.EntireRow.Delete
'Range("F1") = Now() 'to get the end time
End Sub

"Chris" wrote in
message
...
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


.

Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Removing duplicates Tdp Excel Discussion (Misc queries) 6 November 27th 08 12:33 AM
Summing and removing duplicates Marley Excel Discussion (Misc queries) 5 February 4th 07 09:06 AM
Removing Duplicates Danielle Excel Worksheet Functions 5 March 10th 06 07:56 PM
Removing Duplicates sat Excel Discussion (Misc queries) 5 June 18th 05 11:18 PM
Removing Duplicates sat Excel Worksheet Functions 1 June 18th 05 11:18 PM


All times are GMT +1. The time now is 06:16 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement