highlight duplicates

I ve got this code.

Sub zad3()
Dim iWarnColor As Integer
Dim rng As Range
Dim rngCell As Variant




Set rng = Range("B5:E30")



For Each rngCell In rng.Cells
vVal = rngCell.Text
If (WorksheetFunction.CountIf(rng, vVal) = 1) Then
rngCell.Font.Color = RGB(255, 0, 0)
Else
rngCell.Font.Bold = True
End If
Next rngCell


End Sub

Hey,


I want to highlight the first unique values in red and the duplicates of it in bold. Currently I highlight all duplicates. What should I change? Thanks

Please add code tags

You want this to happen in columns B to E or only one specific column?

Will it always be one pair of duplicates or are there chances of having more than 1 duplicates?

Maybe you can attach a sample sheet to make it clear.

Do you have a sample file that you can upload?

Try this code

Option Explicit

Sub highlight_dups()
Dim j As Long, i As Long

Application.ScreenUpdating = False

With Worksheets("Sheet1")
    For j = 2 To 5
        For i = 5 To 30
            If .Cells(i, j).Value = .Cells(i + 1, j).Value And .Cells(i - 1, j).Value <> .Cells(i, j).Value Then
                .Cells(i, j).Font.Color = RGB(255, 0, 0)
                .Cells(i + 1, j).Font.Bold = True
            ElseIf .Cells(i, j).Value = .Cells(i + 1, j).Value And .Cells(i - 1, j).Value = .Cells(i, j).Value Then
                .Cells(i + 1, j).Font.Bold = True
            End If
        Next i
    Next j
End With

MsgBox "Done"

Application.ScreenUpdating = True

End Sub

I can do that, with no issues.

But sometimes it happens that the code i provide works on my file but not on yours.

Anyways, i will provide the code here shortly. Try it and let me know.

Hi dulitu19,

Post back re how this goes:

Option Explicit
Sub Macro1()

    'Written by Trebor76
    'Visit my website www.excelguru.net.au

    Dim clnUniqueValues As New Collection
    Dim rngMyData As Range
    Dim rngCell As Range
    
    Set rngMyData = Range("B5:E30")
    
    Application.ScreenUpdating = False
    
    For Each rngCell In rngMyData
        If Evaluate("COUNTIF(" & rngMyData.Address & "," & rngCell.Address & ")") > 1 Then
            On Error Resume Next
                clnUniqueValues.Add rngCell.Value, CStr(rngCell.Value)
                If Err.Number = 0 Then 'First entry from a block of entries
                    rngCell.Interior.Color = RGB(255, 0, 0)
                Else
                    rngCell.Font.Bold = True
                End If
                Err.Clear
            On Error GoTo 0
        End If
    Next rngCell
    
    Set rngMyData = Nothing
    Set rngCell = Nothing
    Set clnUniqueValues = Nothing
    
    Application.ScreenUpdating = True
    
    MsgBox "Process is now complete"

End Sub

Regards,

Robert