Check for duplicate values


F

Freddy

What VB macro code can be used to check for duplicate values AFTER all
entries are made into a column instead of as they are being entered? I am
running Microsoft Visual Basic 6.5 in Office 2002. I found the code below,
written by Ardus Petus, that checks for duplicate values AS THEY ARE ENTERED:

'----------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
'Adjust next constant to your own needs
Const myColumn As String = "B"
Dim rng As Range
Dim Found As Range

Set rng = Columns(myColumn)
If Intersect(Target, rng) Is Nothing Then Exit Sub
Set Found = rng.Find(Target.Value)
If Found.Address <> Target.Address Then MsgBox ("Duplicate code")
End Sub
'-----------------------------------
 
Ad

Advertisements

J

Jacob Skaria

Modified...Try the below and feedback

Sub Macro()
'Adjust next constant to your own needs
Const myColumn As String = "B"
Dim rng As Range
Dim cell As Range
Dim Found As Range

lngLastRow = ActiveSheet.Cells(Rows.Count, myColumn).End(xlUp).Row
Set rng = Range(mycolumn & "1:" & mycolumn & lngLastRow)
For Each cell In rng
If cell.Text <> "" And IsError(cell.Value) <> True Then
Set Found = rng.Find(cell.Value)
If Not Found Is Nothing Then
If Found.Address <> cell.Address Then cell.Interior.Color = vbRed
End If
End If
Next

End Sub
 
F

Freddy

It worked very well. Can it be modified to inform the user whether or not
duplicates were found and, if necessary, make corrections then rerun the
macro to check for duplicates again?
 
J

Jacob Skaria

Untested...Try and feedback

Sub Macro()
'Adjust next constant to your own needs
Const myColumn As String = "B"
Dim rng As Range
Dim cell As Range
Dim Found As Range
Dim blnCount as Boolean

lngLastRow = ActiveSheet.Cells(Rows.Count, myColumn).End(xlUp).Row
Set rng = Range(mycolumn & "1:" & mycolumn & lngLastRow)
rng.Interior.ColorIndex = xlNone
For Each cell In rng
If cell.Text <> "" And IsError(cell.Value) <> True Then
Set Found = rng.Find(cell.Value)
If Not Found Is Nothing Then
If Found.Address <> cell.Address Then
cell.Interior.Color = vbRed:blnFound = True
End If
End If
End If
Next

If blnFound = True then Msgbox "Duplicates Found"

End Sub
 
J

Jacob Skaria

Typo...corrected..

Sub Macro()
'Adjust next constant to your own needs
Const myColumn As String = "B"
Dim rng As Range
Dim cell As Range
Dim Found As Range
Dim blnFound as Boolean

lngLastRow = ActiveSheet.Cells(Rows.Count, myColumn).End(xlUp).Row
Set rng = Range(mycolumn & "1:" & mycolumn & lngLastRow)
rng.Interior.ColorIndex = xlNone
For Each cell In rng
If cell.Text <> "" And IsError(cell.Value) <> True Then
Set Found = rng.Find(cell.Value)
If Not Found Is Nothing Then
If Found.Address <> cell.Address Then
cell.Interior.Color = vbRed:blnFound = True
End If
End If
End If
Next

If blnFound = True then Msgbox "Duplicates Found"

End Sub
 
Ad

Advertisements

F

Freddy

Tested successfully. I removed "rng.Interior.ColorIndex = xlNone". Would it
be possible to increase the range from one column to multiple columns?
 
Ad

Advertisements


Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Top