VBA - Worksheet change event to highlight duplicates

[Fishboy]

Hi all,

I am working on an Excel 2010 workbook and have implemented the following tweaked code I found online. In essence it is a worksheet change event which highlights cells red when duplicate values are added to column A (which is a list of candidate names).

Option Explicit


Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Row = 1 Then Exit Sub             ' IF ITS A HEADER, DO NOTHING.
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Dim myDataRng As Range
    Dim cell As Range
     
    ' WE WILL SET THE RANGE (SECOND COLUMN).
    Set myDataRng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
     
    For Each cell In myDataRng
        cell.Offset(0, 0).Font.Color = vbBlack          ' DEFAULT COLOR.
    
        ' LOCATE DUPLICATE VALUE(S) IN THE SPECIFIED RANGE OF DATA.
        If Application.Evaluate("COUNTIF(" & myDataRng.Address & "," & cell.Address & ")") > 1 Then
            cell.Offset(0, 0).Interior.Color = vbRed        ' CHANGE CELL COLOR TO RED.
        End If
    Next cell
     
    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

This code is working fine as is, however I need to expand upon the scope it is using to determine if this is a duplicate or not. My data is laid out as per the example below:

Excel 2010

	A	B	C

<colgroup><col style="width: 25pxpx"><col><col><col></colgroup><thead>
</thead><tbody>
[TD="align: center"]1[/TD]
[TD="bgcolor: #403151, align: center"]Candidate
Name[/TD]
[TD="bgcolor: #403151, align: center"]Contact
Number[/TD]
[TD="bgcolor: #403151, align: center"]Email
Address[/TD]

[TD="align: center"]2[/TD]
[TD="align: center"]Piotr Pagowski[/TD]
[TD="align: center"]07749 xxxxxx[/TD]
[TD="align: center"]p.pagowski@xxxxxx.com[/TD]

[TD="align: center"]3[/TD]
[TD="align: center"]David Lewis[/TD]
[TD="align: center"]07967 xxxxxx[/TD]
[TD="align: center"]dave135400@xxxxxx.com[/TD]

[TD="align: center"]4[/TD]
[TD="align: center"]Piotr Klimecki[/TD]
[TD="align: center"]07511 xxxxxx[/TD]
[TD="align: center"]piter62@xxxxxx.pl[/TD]

[TD="align: center"]5[/TD]
[TD="align: center"]Andrew Flower[/TD]
[TD="align: center"]01992 xxxxxx[/TD]
[TD="align: center"]andrew.flower33@xxxxxx.com[/TD]

[TD="align: center"]6[/TD]
[TD="align: center"]Benjamin Matthews[/TD]
[TD="align: center"]07973 xxxxxx[/TD]
[TD="align: center"]bmatthews@xxxxxx.com[/TD]

[TD="align: center"]7[/TD]
[TD="align: center"]Trevor Campbell[/TD]
[TD="align: center"]07546 xxxxxx[/TD]
[TD="align: center"]trevorcampbell13@xxxxxx.co.uk[/TD]

</tbody>

Sheet1​

I realise there are no duplicates in my example, but it just to demonstrate how the data is laid out. Ultimately I need to tweak the code so that it checks columns A:C and only highlights the cells if ALL THREE columns match another entry. There are a whole load of other columns of data after column C, but it is the name, contact number and email address we will use to identify duplicates.

Can anyone help at all?

 

[RCBricker]

I re-wrote the code a little. For some reason I couldn't get the countif working and it was driving me nuts trying to figure it out.

This does what you asked, but someone might come along and give you a solution that includes the countif.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Row = 1 Then Exit Sub             ' IF ITS A HEADER, DO NOTHING.
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Dim myDataRng As Range
    Dim cell As Range
    Dim myCONdata As String
    Dim NewCondata As String
    Dim Mydatarng2 As Range
    Dim cell2 As Range
    Dim conCell As Range
    Dim sh As Worksheet
    
    Set sh = ActiveSheet
    With sh
    NewCondata = Cells(Target.Row, 1) & Cells(Target.Row, 2) & Cells(Target.Row, 3)
        ' WE WILL SET THE RANGE (SECOND COLUMN).
        Set myDataRng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        
        Set Mydatarng2 = Range("A1:C" & Cells(Rows.Count, "A").End(xlUp).Row)
        For Each cell In myDataRng
            myCONdata = Cells(cell.Row, 1) & Cells(cell.Row, 2) & Cells(cell.Row, 3)
            cell.Offset(0, 0).Font.Color = vbBlack
            If NewCondata = myCONdata Then
                cell.Offset(0, 0).Interior.Color = vbRed
            Else
            End If
        Next cell
    End With
    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

rich

 

[Fishboy]

Hi Rich, thanks for the input.

Unfortunately I couldn't seem to get this working (or at least not beyond what I already had working anyway). Currently if the value in column A is a duplicate it highlights red before columns B or C are even touched. I suspect a future version of this will only apply the check once column C has been completed, as technically the criteria of all 3 columns being a duplicate cannot be fulfilled until all 3 cells have a value.

Something I hadn't accounted for which your code highlighted for me is once the duplicate is removed the cells should go back to no fill or xlColorIndexNone or whatever. I thought it was something broken in your code but when I checked my code had the same issue.

Back to the drawing board I guess. If anyone has any other suggestions I am more than happy to hear them.

 

[RCBricker]

The code should be fine regardless if the values are entered into Column B or C. It just would not return a duplicate entry. Also, The code only colors Column A cells.

The code will create a concatenation of the values in columns A B & C of the target row. It then creates a range of all cells from cells A1 through the last row used in column A (should be target row). Next it cycles through each cell in that range starting with cell A1. Creates A concatenation of that row Columns A B & C and checks it against the concatenation of the target cells. if they match both cells in Column A are colored red.

Here is the code again. I add a line to take out the existing color in column A and to only run if the target cell had a row higher than 1 and only if target cell is in the 3rd column.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Row = 1 Or Target.Column <> 3 Then Exit Sub             ' IF ITS A HEADER, DO NOTHING.
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Dim myDataRng As Range
    Dim cell As Range
    Dim myCONdata As String
    Dim NewCondata As String
    Dim Mydatarng2 As Range
    Dim cell2 As Range
    Dim conCell As Range
    Dim sh As Worksheet
    
    Set sh = ActiveSheet
    With sh
    NewCondata = Cells(Target.Row, 1) & Cells(Target.Row, 2) & Cells(Target.Row, 3)
        ' WE WILL SET THE RANGE (SECOND COLUMN).
        Set myDataRng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        
        myDataRng.Interior.Pattern = xlNone
        
        For Each cell In myDataRng
            myCONdata = Cells(cell.Row, 1) & Cells(cell.Row, 2) & Cells(cell.Row, 3)
            cell.Offset(0, 0).Font.Color = vbBlack
            If NewCondata = myCONdata Then
                cell.Offset(0, 0).Interior.Color = vbRed
            Else
            End If
        Next cell
    End With
    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

rich

 

[RCBricker]

This is the same code except that it now colors the cells in columns A B & C. and clears the color once the dup is removed.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Row = 1 Or Target.Column <> 3 Then Exit Sub             ' IF ITS A HEADER, DO NOTHING.
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Dim myDataRng As Range
    Dim cell As Range
    Dim myCONdata As String
    Dim NewCondata As String
    Dim Mydatarng2 As Range
    Dim cell2 As Range
    Dim conCell As Range
    Dim sh As Worksheet
    
    Set sh = ActiveSheet
    With sh
    NewCondata = Cells(Target.Row, 1) & Cells(Target.Row, 2) & Cells(Target.Row, 3)
        ' WE WILL SET THE RANGE (SECOND COLUMN).
        Set myDataRng = Range("A1:C" & Cells(Rows.Count, "A").End(xlUp).Row)
        myDataRng.Interior.Pattern = xlNone
        
        Set myDataRng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        For Each cell In myDataRng
            myCONdata = Cells(cell.Row, 1) & Cells(cell.Row, 2) & Cells(cell.Row, 3)
            cell.Offset(0, 0).Font.Color = vbBlack
            If NewCondata = myCONdata Then
                Range(.Cells(cell.Row, cell.Column), .Cells(cell.Row, _
                    cell.Offset(, 2).Column)).Interior.Color = vbRed
            Else
            End If
        Next cell
    End With
    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

if it is not working, we need to figure out way. Can you post an example of the data where it did not work?

Rich

 

[Fishboy]

This is the same code except that it now colors the cells in columns A B & C. and clears the color once the dup is removed.

Private Sub Worksheet_Change(ByVal Target As Range)
    
    If Target.Row = 1 Or Target.Column <> 3 Then Exit Sub             ' IF ITS A HEADER, DO NOTHING.
    
    On Error GoTo ErrHandler
    Application.ScreenUpdating = False
    
    Dim myDataRng As Range
    Dim cell As Range
    Dim myCONdata As String
    Dim NewCondata As String
    Dim Mydatarng2 As Range
    Dim cell2 As Range
    Dim conCell As Range
    Dim sh As Worksheet
    
    Set sh = ActiveSheet
    With sh
    NewCondata = Cells(Target.Row, 1) & Cells(Target.Row, 2) & Cells(Target.Row, 3)
        ' WE WILL SET THE RANGE (SECOND COLUMN).
        Set myDataRng = Range("A1:C" & Cells(Rows.Count, "A").End(xlUp).Row)
        myDataRng.Interior.Pattern = xlNone
        
        Set myDataRng = Range("A1:A" & Cells(Rows.Count, "A").End(xlUp).Row)
        For Each cell In myDataRng
            myCONdata = Cells(cell.Row, 1) & Cells(cell.Row, 2) & Cells(cell.Row, 3)
            cell.Offset(0, 0).Font.Color = vbBlack
            If NewCondata = myCONdata Then
                Range(.Cells(cell.Row, cell.Column), .Cells(cell.Row, _
                    cell.Offset(, 2).Column)).Interior.Color = vbRed
            Else
            End If
        Next cell
    End With
    Set myDataRng = Nothing
ErrHandler:
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

if it is not working, we need to figure out way. Can you post an example of the data where it did not work?

Rich

Hi Rich, I'll give this new code a test and get back to you.

Thanks again for your help mate.

 

[Fishboy]

Hmm, this didn't work as expected either I'm afraid. As soon as a value goes into column C it flags them as duplicates even when they aren't. On a correctly flagged duplicate, removing one of the duplicated values only removes the highlight from one of the rows and not the other.

Having done some testing of my own I have started leaning towards another approach entirely. Now I am only comparing the values of column A (names) and column C (email addresses) to flag duplicates. Telephone numbers being entered in even so much as a slightly different format meant they were not being flagged as duplicates so I have removed them from the equation.

So now on the main data sheet I have the following code which only applies after an email address has been entered. This prevents multiple John Smiths being flagged as duplicates unless they all have the same email address as well:

Private Sub Worksheet_Change(ByVal Target As Range)
' When email address is entered macro is triggered to flag duplicate entries
If Target.Column = 3 Then
Call Dupes
End If
End Sub

Then in a standard module i have created the following macro called "Dupes".

Sub Dupes()
Application.ScreenUpdating = False
Dim LastRow As Long, NamesCol As Long, EmailCol As Long
LastRow = Cells.Find(What:="*", SearchOrder:=xlByRows, Searchdirection:=xlPrevious).Row
NamesCol = 1 'A column with Names
EmailCol = 3 'C column with Email addresses
Columns(NamesCol).Interior.ColorIndex = xlNone
For i = 1 To LastRow
If 1 < Application.WorksheetFunction.CountIfs(Range(Cells(1, NamesCol), Cells(LastRow, NamesCol)), _
                  Cells(i, NamesCol), _
                  Range(Cells(1, EmailCol), Cells(LastRow, EmailCol)), _
                  Cells(i, EmailCol)) _
                  Then Cells(i, 1).Interior.ColorIndex = 3
Next i
End Sub

This seems to be doing what I need it do without issue, so unless someone has a cleverer workaround I think I will probably stick with this for now.

Thanks for your input anyway mate, your help was most appreciated