 Search:

# MS Office Forum

Ask Question   UnAnswered
RSS Feeds

# Finding duplicates in a range

Asked By: Howard    Date: Nov 18    Category: MS Office    Views: 1952

I have this code which finds duplicates from a range and gives red
color to the duplicates. I want someone to modify this code so that
both the exact match cases should get red color.

eg... i have william, henry, suzanne, william, henry in a range of
cells. Both the william's should get red color and both the henry's
too. With the code i have only one william and one henry becomes red
color.

Here's the code.

Private Sub CommandButton1_Click()
Dim i, j, k
Dim objdict As Dictionary
Dim objsheet As Worksheet
Set objdict = New Dictionary
Set objsheet = Sheets("Sheet1")
k = 1
For j = 2 To 5
For i = 1 To 250
If objdict.exists(objsheet.Cells(i, j).Value) Then
objsheet.Cells(i, j).Font.Color = 255
Else
objdict.Add objsheet.Cells(i, j).Value, k
k = k + 1
End If
Next
Next

End Sub

Share:

### 3 Answers Found

Answer #1    Answered By: Cay Nguyen     Answered On: Nov 18

You don't need VBA for this. Conditional formatting will do it. Base
your conditional formula on a COUNTIF statement, highlighting wheere the
COUNTIF gives a value  of >1 when the individual cell is compared to the
whole range  of names.

Answer #2    Answered By: Corbin Jones     Answered On: Nov 18

I designed today a formula how does just that and even uses a dynamic range
for itself to function...

=AANTAL.ALS(VERSCHUIVING(\$A\$2;0;0;AANTALARG(\$A:\$A)-1;AANTALARG(\$A\$2:\$B\$2));A
2)>1

where:
AANTAL.ALS = COUNTIF
VERSCHUIVING = OFFSET
AANTALARG = COUNTA

Be sure to be on A1 of the range  (= A2 in my example because row 1 contains
labels). Notice that it takes all the rows in account and only two columns
so

=AANTAL.ALS(VERSCHUIVING(\$A\$2;0;0;AANTALARG(\$A:\$A)-1;2);A2)>1

does the same as the formula above.

Answer #3    Answered By: Taylor Evans     Answered On: Nov 18

This worked for me:

Private Sub CommandButton1_Click()
Dim i, j, k, j1, i1, limit
Dim objdict As Dictionary
Dim objsheet As Worksheet
Set objdict = New Dictionary
Set objsheet = Sheets("Sheet1")
k = 1
For j = 2 To 5
For i = 1 To 250
If objdict.exists(objsheet.Cells(i, j).Value) Then
objsheet.Cells(i, j).Font.Color = 255
If Not IsEmpty(objsheet.Cells(i, j)) Then
For j1 = 2 To j
If j1 = j Then limit = i - 1 Else limit = 250
For i1 = 1 To limit
If objsheet.Cells(i, j).Value = _
objsheet.Cells(i1, j1).Value _
Then objsheet.Cells(i1, j1).Font.Color = 255
Next i1
Next j1
End If
Else
If Not IsEmpty(objsheet.Cells(i, j)) Then objdict.Add objsheet.Cells
(i, j).Value, k
k = k + 1
End If
Next
Next
End Sub

There were a few problems with it adding the first empty cell it came
across as an item in the dictionary which then slowed the rest down
as it scanned for repeats of empty cells and changed the empty cell's
font to red  but that is now catered for.

Didn't find what you were looking for? Find more on Finding duplicates in a range Or get search suggestion and latest updates.

Tagged: