Highlight duplicates for twice only

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Highlight duplicates for twice only

Post by YasserKhalil »

Hello everyone
I have a column with some data like that
Teacher1 >> A2
Teacher2 >> A3
Teacher3 >> A4
Teacher1 >> A5
Teacher4 >> A6
Teacher3 >> A7
Teacher1 >> A8
Manager1 >> A9
Manager2 >> A10
Manager1 >> A11
Manager2 >> A12

I need to highlight only the cells that starts with the string "Teacher" and to match each two pairs with the same string exactly with a unique color
So Teacher1 in A2 and Teacher1 in A5 to be highlighted with the same unique color and ignore the cell A8 which has no equivalent
Cells from A9 to A12 will be ignored as the starting string isn't Teacher

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: Highlight duplicates for twice only

Post by HansV »

Code: Select all

Sub HighlightDups()
    Dim r As Long
    Dim m As Long
    Dim n As Long
    Dim d As Object
    Application.ScreenUpdating = False
    Set d = CreateObject("Scripting.Dictionary")
    n = 2
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = 2 To m
        If Range("A" & r).Value Like "Teacher*" Then
            If Application.CountIf(Range("A2:A" & m), Range("A" & r).Value) > 1 Then
                If Not d.exists(Range("A" & r).Value) Then
                    n = n + 1
                    d.Add Key:=Range("A" & r).Value, Item:=n
                End If
                Range("A" & r).Interior.ColorIndex = d(Range("A" & r).Value)
            End If
        End If
    Next r
    Application.ScreenUpdating = True
End Sub
Best wishes,
Hans

YasserKhalil
PlatinumLounger
Posts: 4911
Joined: 31 Aug 2016, 09:02

Re: Highlight duplicates for twice only

Post by YasserKhalil »

Amazing. Thank you very much.