Exit Sub when two duplicates values found

[tobysimon]

Hello Experts,

Am trying to execute a code where if Column "B" as more than 1 duplicate value in each cell then a msgbox "Duplicate Entry Made" would pop and exits the Sub. But if no duplicate found it will run the entire script. I've tried Evaluation.Countif.Unique but nothing seems to work.

Thank you in advance.

 

[myall_blues]

Suggest you check out the answer posted here by "Tim" that uses the dictionary. Among the advantages, it's very fast.

Sub ColumnDuplicates()
Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long

lastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, "B").End(xlUp).Row
Set oDictionary = CreateObject("Scripting.Dictionary")
For iCntr = 1 To lastRow
    If Cells(iCntr, 2) <> "" Then
        If oDictionary.Exists(Cells(iCntr, 2).Value) Then
            MsgBox ("Duplicate entry made.")
            Exit Sub
        Else 
            oDictionary.Add Cells(iCntr, 2).Value, Cells(iCntr, 2).Value
        End If
    End If
Next
MsgBox ("No Duplicates in Column B")
End Sub

 

[Fuji]

Other option,

    Dim s$
    s = Range("b2", Range("b" & Rows.Count).End(xlUp)).Address
    If Evaluate("counta(" & s & ")>counta(unique(" & s & "))") Then
        MsgBox "Duplicate Entry Made": Exit Sub
    End If