Highlighting duplicate value based on column values

Monty9

New Member
Joined
Feb 26, 2016
Messages
28
Office Version
  1. 365
Platform
  1. Windows
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
ColorBlack
ColorWhite
ColorBlack
ColorGrey
BreedGerman Shephard
BreedGerman Shephard
BreedLabra
BreedHusky

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
 

Excel Facts

Create a chart in one keystroke
Select the data and press Alt+F1 to insert a default chart. You can change the default chart to any chart type
Hello, a VBA demonstration for starters :​
VBA Code:
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
 
Upvote 0
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:

VBA Code:
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
 
Upvote 0
Solution
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:

VBA Code:
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?
 
Upvote 0
If you have hundreds of row, I think using dictionary is faster even though going through loop twice. Probably, there is other better approach.
VBA Code:
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
 
Upvote 0
No need, it's clear from the code that Zot's right. !!
 
Upvote 0
You too you did not give it a try so try to explain how Cells(R, 2) can highlight two columns ?‼​
 
Upvote 0
Try reading the post that you actually quoted. Instead of jumping to the conclusion that Zot was talking about your code.
 
Upvote 0
Ok you are right it's not my post, my bad …​
 
Upvote 0

Forum statistics

Threads
1,223,214
Messages
6,170,771
Members
452,353
Latest member
strainu

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top