Highlighting duplicate value based on column values

[Monty9]

Hello,

I am trying to find a way to perform a check to highlight duplicate values based on the value in another column. For example in the table below I have 2 sorted columns A and B, I need to iterate each value in Column A and highlight duplicate values in Column B

​

Column A​	Column B​
Color	Black
Color	White
Color	Black
Color	Grey
Breed	German Shephard
Breed	German Shephard
Breed	Labra
Breed	Husky

Here, in Column A for Color the code should iterate Column B and highlight duplicate (for ex. Black is highlighted) and then going to the next value in Column A i.e. Breed the code should again look and highlight duplicates (for ex. German Shephard)

Thank You

 

[Marc L]

Hello, a VBA demonstration for starters :​

Sub Demo1()
    Dim V, R&
        V = Evaluate(Replace("IF({1},COUNTIFS($A$1:$A$#,$A$1:$A$#,$B$1:$B$#,$B$1:$B$#))", "#", [A1].CurrentRegion.Rows.Count))
        Application.ScreenUpdating = False
    For R = 1 To UBound(V)
        If V(R, 1) > 1 Then Cells(R, 2).Font.Color = vbRed
    Next
        Application.ScreenUpdating = True
End Sub

​

 

[Trebor76]

Though I'd use Marc L's solution (less rows the better I say) here's my attempt which I'm only posting as I had spent some time putting it together:

Option Explicit
Sub Demo2()
    
    'https://www.mrexcel.com/board/threads/highlighting-duplicate-value-based-on-column-values.1184621
    
    Dim varMyArray() As Variant, varItem As Variant
    Dim objDict As Object
    Dim i As Long, lngMyRow As Long, lngLastRow As Long
    Dim ws As Worksheet
    
    Set ws = ThisWorkbook.Sheets("Sheet1") 'Sheet with data. Change to suit if necessary.

    If WorksheetFunction.CountA(ws.Cells) = 0 Then
        MsgBox "There is no data on """ & ws.Name & """.", vbExclamation
        Exit Sub
    End If
    
    Application.ScreenUpdating = False

    lngLastRow = ws.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = 2 To lngLastRow
        i = i + 1
        ReDim Preserve varMyArray(1 To i)
        varMyArray(i) = ws.Range("A" & lngMyRow) & ws.Range("B" & lngMyRow)
    Next lngMyRow
    
    Set objDict = CreateObject("Scripting.Dictionary")
    
    For i = LBound(varMyArray) To UBound(varMyArray)
        If objDict.Exists(varMyArray(i)) Then
            objDict.Item(varMyArray(i)) = objDict.Item(varMyArray(i)) + 1
        Else
            objDict.Add varMyArray(i), 1
        End If
    Next i
    
    For lngMyRow = 2 To lngLastRow
        If objDict.Item(ws.Range("A" & lngMyRow) & ws.Range("B" & lngMyRow)) > 1 Then
            ws.Range("A" & lngMyRow & ":B" & lngMyRow).Font.Color = RGB(255, 0, 0) 'Highlights dups in red font. Change to suit if necessary.
        Else
            ws.Range("A" & lngMyRow & ":B" & lngMyRow).Font.Color = RGB(0, 0, 0)
        End If
    Next lngMyRow
    
    Set objDict = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

This was based on some of the solutions given here.

Regards,

Robert

 

[Zot]

Though I'd use Marc L's solution (less rows the better I say) here's my attempt which I'm only posting as I had spent some time putting it together:

Option Explicit
Sub Demo2()
   
    'https://www.mrexcel.com/board/threads/highlighting-duplicate-value-based-on-column-values.1184621
   
    Dim varMyArray() As Variant, varItem As Variant
    Dim objDict As Object
    Dim i As Long, lngMyRow As Long, lngLastRow As Long
    Dim ws As Worksheet
   
    Set ws = ThisWorkbook.Sheets("Sheet1") 'Sheet with data. Change to suit if necessary.

    If WorksheetFunction.CountA(ws.Cells) = 0 Then
        MsgBox "There is no data on """ & ws.Name & """.", vbExclamation
        Exit Sub
    End If
   
    Application.ScreenUpdating = False

    lngLastRow = ws.Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
    For lngMyRow = 2 To lngLastRow
        i = i + 1
        ReDim Preserve varMyArray(1 To i)
        varMyArray(i) = ws.Range("A" & lngMyRow) & ws.Range("B" & lngMyRow)
    Next lngMyRow
   
    Set objDict = CreateObject("Scripting.Dictionary")
   
    For i = LBound(varMyArray) To UBound(varMyArray)
        If objDict.Exists(varMyArray(i)) Then
            objDict.Item(varMyArray(i)) = objDict.Item(varMyArray(i)) + 1
        Else
            objDict.Add varMyArray(i), 1
        End If
    Next i
   
    For lngMyRow = 2 To lngLastRow
        If objDict.Item(ws.Range("A" & lngMyRow) & ws.Range("B" & lngMyRow)) > 1 Then
            ws.Range("A" & lngMyRow & ":B" & lngMyRow).Font.Color = RGB(255, 0, 0) 'Highlights dups in red font. Change to suit if necessary.
        Else
            ws.Range("A" & lngMyRow & ":B" & lngMyRow).Font.Color = RGB(0, 0, 0)
        End If
    Next lngMyRow
   
    Set objDict = Nothing
   
    Application.ScreenUpdating = True
   
End Sub

This was based on some of the solutions given here.

Regards,

Robert

Looks like this highlight both columns?

 

[Zot]

If you have hundreds of row, I think using dictionary is faster even though going through loop twice. Probably, there is other better approach.

Sub MarkDupe()

Dim strData As String
Dim cell As Range, cellx As Range, rngCat As Range
Dim ws As Worksheet
Dim dictData As Object

Set dictData = CreateObject("Scripting.Dictionary")
Set ws = ActiveWorkbook.ActiveSheet
Set rngCat = ws.Range("A2", ws.Cells(Rows.Count, "A").End(xlUp))

Application.ScreenUpdating = False

For Each cell In rngCat
    strData = cell & "," & cell.Offset(0, 1)
    If Not dictData.Exists(strData) Then
        dictData.Add strData, 1
    Else
        dictData(strData) = dictData(strData) + 1
    End If
Next
For Each cell In rngCat
    strData = cell & "," & cell.Offset(0, 1)
    If dictData(strData) > 1 Then cell.Offset(0, 1).Font.ColorIndex = 3
Next

End Sub

 

[Marc L]

Looks like this highlight both columns?

Try it ‼​

 

[Fluff]

No need, it's clear from the code that Zot's right. !!

 

[Marc L]

​

You too you did not give it a try so try to explain how Cells(R, 2) can highlight two columns ?‼​

 

[Fluff]

Try reading the post that you actually quoted. Instead of jumping to the conclusion that Zot was talking about your code.

 

[Marc L]

​

Ok you are right it's not my post, my bad …​