VBA to find duplicate values in two columns

[rhmkrmi]

Hi there,

I need a VBA to compare two columns and show a message with the number of duplicates found and then stop the user from progressing until the duplicate is made unique.
If the VBA can also highlight the duplicates, it can save me some conditional formatting too.

Example:

Thank you.

 

[EFANYoutube]

Hi rhmkrmi
I went by your example and assumed there wouldn't be 2 duplicates in the second range
this checks each value in first range and tries to find a duplicate in the second, if found it sets the font both red

Sub Validation()
    Dim FirstRng, SecondRng As Range
    Set FirstRng = Sheet1.Range("A:A")
    Set SecondRng = Sheet1.Range("B:B")
   
    If CheckForDups(FirstRng, SecondRng) = True Then
        MsgBox "There were duplicates found and they have been highlighted"
        Exit Sub
    End If
End Sub

Function CheckForDups(ByVal CycleRng As Range, ByVal CheckRng As Range) As Boolean
    Dim cell As Range
    Dim Duplicate As Range
    For Each cell In CycleRng.Cells
        If cell.Value = "" Then Exit For
        Set Duplicate = CheckRng.Find(cell.Value)
        If Not Duplicate Is Nothing Then
            'Duplicate found
            cell.Font.Color = vbRed
            Duplicate.Font.Color = vbRed
            CheckForDups = True
        End If
    Next cell
End Function
[code]

 

[rhmkrmi]

Thank you E.

There may actually be more than one duplicate in both ranges and I also have a condition which I missed in my original post, sorry!
It should look for duplicates only if column C is populated with Shop.

Can we make the code run automatically? I have to manually run the macro now.
It also does not set the font color back to Automatic when I fix the duplication.
I have a bunch of other macros for the same sheet as Private Sub Worksheet_Change(ByVal Target As Range) and tried to include your code in there but it fails.

Thank you.

 

[EFANYoutube]

I have fixed all the issues in the code below.
As for triggering this event you need to reference this code in the Private Sub Worksheet_Change(ByVal Target As Range) by putting in Validation()
some where in there

Private Sub Worksheet_Change(ByVal Target As Range)
    Validation()

'other code

End Sub

I'm not sure a function can work in there so referencing it is the best solution

Sub Validation()
    Dim FirstRng, SecondRng As Range
    Set FirstRng = Sheet1.Range("A:A")
    Set SecondRng = Sheet1.Range("B:B")
   
    If CheckForDups(FirstRng, SecondRng) = True or CheckForDups(SecondRng, FirstRng) = True Then 'run both ranges through to get dups
        MsgBox "There were duplicates found and they have been highlighted"
        Exit Sub
    End If
End Sub

Function CheckForDups(ByVal CycleRng As Range, ByVal CheckRng As Range, First As Boolean) As Boolean

    Dim cell As Range

    Dim Duplicate As Range
    If First = True Then
        CycleRng.Font.Color = vbBlack
        CheckRng.Font.Color = vbBlack
    End If
    For Each cell In CycleRng.Cells

        If cell.Value = "" Then Exit For

        Set Duplicate = CheckRng.Find(cell.Value)

        If Not Duplicate Is Nothing And cell.Parent.Cells(cell.Row, 3) = "Shop" Then

            'Duplicate found

            If cell.Parent.Cells(cell.Row, 3) = "Shop" Then cell.Font.Color = vbRed

            If Duplicate.Parent.Cells(Duplicate.Row, 3) = "Shop" Then Duplicate.Font.Color = vbRed

            CheckForDups = True

        End If

    Next cell

End Function

 

[rhmkrmi]

I have fixed all the issues in the code below.
As for triggering this event you need to reference this code in the Private Sub Worksheet_Change(ByVal Target As Range) by putting in Validation()
some where in there

Private Sub Worksheet_Change(ByVal Target As Range)
    Validation()

'other code

End Sub

I'm not sure a function can work in there so referencing it is the best solution

Sub Validation()
    Dim FirstRng, SecondRng As Range
    Set FirstRng = Sheet1.Range("A:A")
    Set SecondRng = Sheet1.Range("B:B")
  
    If CheckForDups(FirstRng, SecondRng) = True or CheckForDups(SecondRng, FirstRng) = True Then 'run both ranges through to get dups
        MsgBox "There were duplicates found and they have been highlighted"
        Exit Sub
    End If
End Sub

Function CheckForDups(ByVal CycleRng As Range, ByVal CheckRng As Range, First As Boolean) As Boolean

    Dim cell As Range

    Dim Duplicate As Range
    If First = True Then
        CycleRng.Font.Color = vbBlack
        CheckRng.Font.Color = vbBlack
    End If
    For Each cell In CycleRng.Cells

        If cell.Value = "" Then Exit For

        Set Duplicate = CheckRng.Find(cell.Value)

        If Not Duplicate Is Nothing And cell.Parent.Cells(cell.Row, 3) = "Shop" Then

            'Duplicate found

            If cell.Parent.Cells(cell.Row, 3) = "Shop" Then cell.Font.Color = vbRed

            If Duplicate.Parent.Cells(Duplicate.Row, 3) = "Shop" Then Duplicate.Font.Color = vbRed

            CheckForDups = True

        End If

    Next cell

End Function

Thank you.

I tried to run it individually in a new workbook and get this error:

 

[EFANYoutube]

Hi
Looks like I missed a spot.
Make this line
If CheckForDups(FirstRng, SecondRng) = True or CheckForDups(SecondRng, FirstRng) = True Then

Say
If CheckForDups(FirstRng, SecondRng, True) = True or CheckForDups(SecondRng, FirstRng, False) = True Then