Duplicate Msgbox

[Aaron]

I foud the following code but would like to add a msgbox that if Duplicates
found
A msgbox is tiggered and shows the count of the Duplicates..

Sub HighlightDuplicates()

'Highlight duplicates in Yellow
Dim Cell As Range
Dim Cell_Range As Range
Dim MyCollection As New Collection

'Find last cell entry in the row
LastEntry = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Address
'Define the range to examine
Set Cell_Range = ActiveSheet.Range("B1", LastEntry)

For Each Cell In Cell_Range
On Error Resume Next
MyCollection.Add Item:="1", Key:=Cell.Text
If Err.Number = 457 Then
Cell.Interior.ColorIndex = 6
Err.Clear
End If
Next Cell

End Sub



Thanks,
Aaron

 

[PCLIVE]

One way,

Sub HighlightDuplicates()

'Highlight duplicates in Yellow
Dim Cell As Range
Dim Cell_Range As Range
Dim MyCollection As New Collection
n = 0
'Find last cell entry in the row
LastEntry = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Address
'Define the range to examine
Set Cell_Range = ActiveSheet.Range("B1", LastEntry)

For Each Cell In Cell_Range
On Error Resume Next
MyCollection.Add Item:="1", Key:=Cell.Text
If Err.Number = 457 Then
Cell.Interior.ColorIndex = 6
Err.Clear
n = n + 1
End If
Next Cell

If n = 1 _
Then
v = "is "
noun = " duplicate."
Else:
v = "are "
noun = " duplicates."
End If

MsgBox ("There " & v & n & noun)
End Sub


Keep in mind that this will only display the number of duplicates, not
including the original one. Example, if you have a value that repeats once,
then you only have one duplicate. If you want the total number of a value
that is duplicated, then you would need to change "n = 0" to "n = 1" at the
top of the code.

HTH,
Paul

 

[Gary''s Student]

Sub HighlightDuplicates()

'Highlight duplicates in Yellow
Dim Cell As Range
Dim Cell_Range As Range
Dim MyCollection As New Collection

Dim IAmTheCount As Long

'Find last cell entry in the row
LastEntry = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Address
'Define the range to examine
Set Cell_Range = ActiveSheet.Range("B1", LastEntry)

For Each Cell In Cell_Range
On Error Resume Next
MyCollection.Add Item:="1", Key:=Cell.Text
If Err.Number = 457 Then
Cell.Interior.ColorIndex = 6
IAmTheCount = IAmTheCount + 1
Err.Clear
End If
Next Cell
MsgBox (IAmTheCount)
End Sub

 

[PCLIVE]

I forgot to include code for if there are no duplicates. I've updated it
below. However, I didn't not account for possible duplicate blank cells.
Regards,
Paul

Sub HighlightDuplicates()

'Highlight duplicates in Yellow
Dim Cell As Range
Dim Cell_Range As Range
Dim MyCollection As New Collection
n = 0
'Find last cell entry in the row
LastEntry = ActiveSheet.Cells(Rows.Count, "B").End(xlUp).Address
'Define the range to examine
Set Cell_Range = ActiveSheet.Range("B1", LastEntry)

For Each Cell In Cell_Range
On Error Resume Next
MyCollection.Add Item:="1", Key:=Cell.Text
If Err.Number = 457 Then
Cell.Interior.ColorIndex = 6
Err.Clear
n = n + 1
End If
Next Cell

If n > 0 _
Then
If n = 1 _
Then
v = "is "
noun = " duplicate."
Else:
v = "are "
noun = " duplicates."
End If

MsgBox ("There " & v & n & noun)
Else:
MsgBox ("There are no duplicates.")
End If

End Sub