Search: | |||||

| ||||

Home » Forum » MS Office | RSS Feeds |

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

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.

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.

Related Topics:

- Finding duplicates from an excel range and coloring them automatically
- highlight a range using a named range
- Need help in finding duplicates
- how to find out if a c ell is inside a range
- modify a macro to find the selected range
- Find a match in a range and copy contents to templates workbook
- Add-Ins loaded into Excel
- RDB design, Avoiding Duplicate Records
- Duplicates in different colors from 2 tables
- using find find all
- Help with duplicates
- Newbie VBA question about duplicates
- Help on Removing Duplicates in Excel
- delete duplicate PERSONAL workbook?
- Need Help In Deleting Duplicate Items in Excel a excel file
- Highlight duplicate values of certain columns only
- How to delete duplicate thru vba
- Duplicates in a collection
- Getting a range of values
- subscript out of range
- Mimi's range selection macro
- Insert Rows, based on data in range, using VBA
- Array and Range
- Create Dynamic Ranges in VB
- Create Dynamic Ranges in VB