Restricting duplicate value in excel vba-CodePudding

I have macro enabled excel file - Sheet_Change.xlsm

I need to restrict users entering duplicate values in the columns 2 and 5 compared to the columns 2 and 5 in a previous row

But in my code (below) it restricts entering duplicates in case if either Column 2 OR Column 5 has duplicates compared to the values for these columns in a previous row. While my goal is to have a warning / action - when both columns have duplicate values

Plz see screenshot example:

Please, help!

I am using the following vba code, in "Sheet1":

     Private Sub Worksheet_Change(ByVal Target As Range)
     With Target
          If (.Column <> 2 And .Column <> 5) Or .Cells.Count > 1 Then Exit Sub

          If WorksheetFunction.CountIfs(Columns(.Column), .Value) > 1 Then
             Application.DisplayAlerts = False
             .ClearContents
             Application.DisplayAlerts = True
             MsgBox "Duplicate value!"
          End If

    End With
    End Sub

CodePudding user response：

Use Find, FindNext on column 2 and then check the value in column 5. Note - this will find duplicate in any row not just the previous.

Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const PK1 = 2 ' Primary Keys
    Const PK2 = 5

    Dim V1, V2, rng As Range, first As String
    
    If (Target.Column = PK1) Or (Target.Column = PK2) Then
        V1 = Me.Cells(Target.Row, PK1) ' B
        V2 = Me.Cells(Target.Row, PK2) ' E
        If V1 = "" Or V2 = "" Then Exit Sub
    Else
        Exit Sub
    End If
    
    With Me.Columns(PK1)
        Set rng = .Find(V1, lookat:=xlWhole, LookIn:=xlValues)
        If Not rng Is Nothing Then
            first = rng.Address
            Do
               If (rng.Row <> Target.Row) And (Cells(rng.Row, PK2) = V2) Then
                  MsgBox "Duplicate Value " & V1 & "," & V2, vbExclamation, "Row " & rng.Row
                  Target.Select
                  Application.EnableEvents = False
                  Target.Clear
                  Application.EnableEvents = True
                  Exit Do
               End If
               Set rng = .FindNext(rng)
            Loop While rng.Address <> first
         End If
    End With
    
End Sub