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
- Find a match in a range and copy contents to templates workbook
- modify a macro to find the selected range
- how to find out if a c ell is inside a range
- Add-Ins loaded into Excel
- Highlight duplicate values of certain columns only
- Need Help In Deleting Duplicate Items in Excel a excel file
- delete duplicate PERSONAL workbook?
- How to delete duplicate thru vba
- Duplicates in a collection
- Newbie VBA question about duplicates
- Help on Removing Duplicates in Excel
- Duplicates in different colors from 2 tables
- using find find all
- Help with duplicates
- RDB design, Avoiding Duplicate Records
- VBA Code for pasting a set of formulas down a data range
- Copying a range from 1 sheet to another
- using macro to create dynamic named ranges
- Date range in pivot table
- Code for date ranges
- Range question for DSUM, DCOUNT, etc...
- Reference range row and column in VBA