Deleting Duplicate with a Msg box which displays no of duplicates

U

Uma Nandan

Hi

Would kindly request you to help for the following:

1) I need a VBA Code to detect the duplicates based on below data. Have
given my comments in Column D for for more information.
2) After checking Column B with Column A & Column C the duplicates should be
detleted & should pop a message box that these many duplicates deleted. In
below mentioned Eg. the message box should display " Total Duplicated
Detected:2 , Unique Records:4"
__________________________________________________________

EG:

Column A ColumnB ColumnC Column D
COMPANY NAME PROSPECT NAME TITLE COMMENTS
Wachovia David Wishon SVP Not a duplicate
Wachovia David Wishon Associate Not a duplicate
Bank Of America Uma Nandan Researcher Not a duplicate
Citigroup Uma Nandan Researcher Not a duplicate
Wachovia David Wishon Associate Duplicate. Need to
delete
Bank Of America Uma Nandan Researcher Duplicate. Need to delete

_____________________________________________________________
Would appreciate if some one can help me with this. I have a data of 50,000
to perform this task.

Thanks in advance.

Regards,
Uma
 
B

Bernie Deitrick

Uma,

Sub UmaMacro()
Dim myR As Long
Dim myC As Range
Dim myR2 As Long

myR = Cells(Rows.Count, 1).End(xlUp).Row
Range("D2").EntireColumn.Insert

With Range("D2:D" & myR)
.FormulaR1C1 = _
"=SUMPRODUCT((RC[-3]=R2C1:RC1)*(RC[-2]=R2C2:RC2)*(RC[-1]=R2C3:RC3))"
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Range("D1").Value = "Sort"
Range("A1:D" & myR).Sort Key1:=Range("D2"), _
Order1:=xlAscending, Header:= xlYes
Set myC = Columns("D:D").Find(What:="2")
Range(myC, Cells(myR, 4)).EntireRow.Delete
Range("D2").EntireColumn.Delete
myR2 = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "I deleted " & myR - myR2 & " and there were " _
& myR2 - 1 & " that I did not delete."
End Sub

HTH,
Bernie
MS Excel MVP
 
P

Per Jessen

Hi Uma

Try this:

Sub DeleteDuplicates()
Dim StartCell As Range
Dim LastCell As Range
Dim NoOfRec As Long
Dim NoOfUniq As Long
Dim NoOfDup As Long
Dim TempSh As Worksheet
Dim FilterSh As Worksheet

Application.ScreenUpdating = False

Set FilterSh = Worksheets("Sheet1")
Set TempSh = Worksheets.Add
FilterSh.Activate
Set StartCell = Range("A1")
Set LastCell = StartCell.End(xlDown)
NoOfRec = LastCell.Row - StartCell.Row

FilterSh.Range(StartCell, LastCell.Offset(0, 2)).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=TempSh.Range( _
"A1"), Unique:=True

NoOfUniq = TempSh.Range("A2", TempSh.Range("A2").End
(xlDown)).Rows.Count
NoOfDup = NoOfRec - NoOfUniq

FilterSh.Range(StartCell, LastCell.Offset(0, 2)).Delete
With TempSh
.Range("A1", .Range("A1").End(xlDown).Offset(0, 2)).Copy _
Destination:=FilterSh.Range("A1")
End With

With Application
.DisplayAlerts = False
TempSh.Delete
.DisplayAlerts = True
.ScreenUpdating = True
End With
Msg = MsgBox("Total Duplicated Detected: " & NoOfDup & vbLf & vbLf _
& "Unique Records: " & NoOfUniq, vbInformation, "Hello")
End Sub

Regards,
Per
 
U

Uma Nandan

Hi Bernie,

Thanks for your quick response.
This works fantastic. However if there is no duplicates, i get a runtime
Error.
So is there any way to do something for that.

thank you so much once again

Regards,
Uma

Bernie Deitrick said:
Uma,

Sub UmaMacro()
Dim myR As Long
Dim myC As Range
Dim myR2 As Long

myR = Cells(Rows.Count, 1).End(xlUp).Row
Range("D2").EntireColumn.Insert

With Range("D2:D" & myR)
.FormulaR1C1 = _
"=SUMPRODUCT((RC[-3]=R2C1:RC1)*(RC[-2]=R2C2:RC2)*(RC[-1]=R2C3:RC3))"
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Range("D1").Value = "Sort"
Range("A1:D" & myR).Sort Key1:=Range("D2"), _
Order1:=xlAscending, Header:= xlYes
Set myC = Columns("D:D").Find(What:="2")
Range(myC, Cells(myR, 4)).EntireRow.Delete
Range("D2").EntireColumn.Delete
myR2 = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "I deleted " & myR - myR2 & " and there were " _
& myR2 - 1 & " that I did not delete."
End Sub

HTH,
Bernie
MS Excel MVP


Uma Nandan said:
Hi

Would kindly request you to help for the following:

1) I need a VBA Code to detect the duplicates based on below data. Have
given my comments in Column D for for more information.
2) After checking Column B with Column A & Column C the duplicates should be
detleted & should pop a message box that these many duplicates deleted. In
below mentioned Eg. the message box should display " Total Duplicated
Detected:2 , Unique Records:4"
__________________________________________________________

EG:

Column A ColumnB ColumnC Column D
COMPANY NAME PROSPECT NAME TITLE COMMENTS
Wachovia David Wishon SVP Not a duplicate
Wachovia David Wishon Associate Not a duplicate
Bank Of America Uma Nandan Researcher Not a duplicate
Citigroup Uma Nandan Researcher Not a duplicate
Wachovia David Wishon Associate Duplicate. Need to
delete
Bank Of America Uma Nandan Researcher Duplicate. Need to delete

_____________________________________________________________
Would appreciate if some one can help me with this. I have a data of 50,000
to perform this task.

Thanks in advance.

Regards,
Uma
Click to expand...
Click to expand...
 
U

Uma Nandan

Hi Per,

Thanks of your code.
However this code is showing me compile Error at the following:

NoOfUniq = TempSh.Range("A2", TempSh.Range("A2").End
(xlDown)).Rows.Count

I wasnt' able to run the code cause of the error.

Regards,
Uma
 
P

Per Jessen

Hi Uma

Thanks for your reply.

I think the problem is due to word wrap in your news reader.

The two lines mentioned shall be one line in the macro editor.

Hopes it helps.

Regards,
Per
 
B

Bernie Deitrick

After the line

Set myC = Columns("D:D").Find(What:="2")

put the line

On Error Resume Next


Bernie

Uma Nandan said:
Hi Bernie,

Thanks for your quick response.
This works fantastic. However if there is no duplicates, i get a runtime
Error.
So is there any way to do something for that.

thank you so much once again

Regards,
Uma

Bernie Deitrick said:
Uma,

Sub UmaMacro()
Dim myR As Long
Dim myC As Range
Dim myR2 As Long

myR = Cells(Rows.Count, 1).End(xlUp).Row
Range("D2").EntireColumn.Insert

With Range("D2:D" & myR)
.FormulaR1C1 = _
"=SUMPRODUCT((RC[-3]=R2C1:RC1)*(RC[-2]=R2C2:RC2)*(RC[-1]=R2C3:RC3))"
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Range("D1").Value = "Sort"
Range("A1:D" & myR).Sort Key1:=Range("D2"), _
Order1:=xlAscending, Header:= xlYes
Set myC = Columns("D:D").Find(What:="2")
Range(myC, Cells(myR, 4)).EntireRow.Delete
Range("D2").EntireColumn.Delete
myR2 = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "I deleted " & myR - myR2 & " and there were " _
& myR2 - 1 & " that I did not delete."
End Sub

HTH,
Bernie
MS Excel MVP


Uma Nandan said:
Hi

Would kindly request you to help for the following:

1) I need a VBA Code to detect the duplicates based on below data. Have
given my comments in Column D for for more information.
2) After checking Column B with Column A & Column C the duplicates
should be
detleted & should pop a message box that these many duplicates deleted.
In
below mentioned Eg. the message box should display " Total Duplicated
Detected:2 , Unique Records:4"
__________________________________________________________

EG:

Column A ColumnB ColumnC Column
D
COMPANY NAME PROSPECT NAME TITLE COMMENTS
Wachovia David Wishon SVP Not a duplicate
Wachovia David Wishon Associate Not a
duplicate
Bank Of America Uma Nandan Researcher Not a duplicate
Citigroup Uma Nandan Researcher Not a
duplicate
Wachovia David Wishon Associate Duplicate.
Need to
delete
Bank Of America Uma Nandan Researcher Duplicate. Need to
delete

_____________________________________________________________
Would appreciate if some one can help me with this. I have a data of
50,000
to perform this task.

Thanks in advance.

Regards,
Uma
Click to expand...
Click to expand...
Click to expand...
 
U

Uma Nandan

Hi Bernie,

You saved me by helping with this following code.
Thank you so much :)

Regards,
Uma

Bernie Deitrick said:
After the line

Set myC = Columns("D:D").Find(What:="2")

put the line

On Error Resume Next


Bernie

Uma Nandan said:
Hi Bernie,

Thanks for your quick response.
This works fantastic. However if there is no duplicates, i get a runtime
Error.
So is there any way to do something for that.

thank you so much once again

Regards,
Uma

Bernie Deitrick said:
Uma,

Sub UmaMacro()
Dim myR As Long
Dim myC As Range
Dim myR2 As Long

myR = Cells(Rows.Count, 1).End(xlUp).Row
Range("D2").EntireColumn.Insert

With Range("D2:D" & myR)
.FormulaR1C1 = _
"=SUMPRODUCT((RC[-3]=R2C1:RC1)*(RC[-2]=R2C2:RC2)*(RC[-1]=R2C3:RC3))"
.Copy
.PasteSpecial Paste:=xlPasteValues
End With
Range("D1").Value = "Sort"
Range("A1:D" & myR).Sort Key1:=Range("D2"), _
Order1:=xlAscending, Header:= xlYes
Set myC = Columns("D:D").Find(What:="2")
Range(myC, Cells(myR, 4)).EntireRow.Delete
Range("D2").EntireColumn.Delete
myR2 = Cells(Rows.Count, 1).End(xlUp).Row
MsgBox "I deleted " & myR - myR2 & " and there were " _
& myR2 - 1 & " that I did not delete."
End Sub

HTH,
Bernie
MS Excel MVP


Hi

Would kindly request you to help for the following:

1) I need a VBA Code to detect the duplicates based on below data. Have
given my comments in Column D for for more information.
2) After checking Column B with Column A & Column C the duplicates
should be
detleted & should pop a message box that these many duplicates deleted.
In
below mentioned Eg. the message box should display " Total Duplicated
Detected:2 , Unique Records:4"
__________________________________________________________

EG:

Column A ColumnB ColumnC Column
D
COMPANY NAME PROSPECT NAME TITLE COMMENTS
Wachovia David Wishon SVP Not a duplicate
Wachovia David Wishon Associate Not a
duplicate
Bank Of America Uma Nandan Researcher Not a duplicate
Citigroup Uma Nandan Researcher Not a
duplicate
Wachovia David Wishon Associate Duplicate.
Need to
delete
Bank Of America Uma Nandan Researcher Duplicate. Need to
delete

_____________________________________________________________
Would appreciate if some one can help me with this. I have a data of
50,000
to perform this task.

Thanks in advance.

Regards,
Uma
Click to expand...
Click to expand...
Click to expand...
 
Top