duplicate entry restriction VBA Code causing issue in other portion

[iffi]

Hi everyone
the following vba code is working fine to restrict the user from entering duplicate entry in column B but i dont have any idea why it is giving pop up window error as soon as i copy or delete data in other portion of excel as shown in the attached image

Private Sub Worksheet_Change(ByVal Target As Range)

If WorksheetFunction.CountIf(Range("B:B"), Target) > 1 Then

    MsgBox "Duplicate Entry Is Not Allowed", vbCritical, "Duplicate Entry"
    Target.Value = ""
    Target.Select
    
End If



End Sub

Please rectify the code so it does not cause any problem while working on any action performed in other portion of excel.

Thanks

 

[Jeffrey Mahoney]

Please try this

Private Sub Worksheet_Change(ByVal Target As Range)

  If Not Intersect(Target, Range("B:B")) Is Nothing Then
    If WorksheetFunction.CountIf(Range("B:B"), Target) > 1 Then
  
      MsgBox "Duplicate Entry Is Not Allowed", vbCritical, "Duplicate Entry"
      Target.Value = ""
      Target.Select
      
    End If
  End If


End Sub

 

[iffi]

Thanks Jeffrey Mahoney, it is working fine but there is another issue that if i copy two cell together from column a and column b and paste down including the duplicate entry then again the pop up window error shows up as shown in the attached image below. please have a look at this.

Please rectify the code to resolve this issue as well..

Thanks

 

[abdelfattah]

that if i copy two cell together from column a and column b and paste down including the duplicate entry

in this case will not show message based on the code!

 

[Alex Blakenburg]

Give this a try:
Note: If you copy/change multiple cells in column B it will only test the first one. If you want to test them all it will take more code. Another option would be to give an error message if you copy/change multiple cells.

Private Sub Worksheet_Change(ByVal Target As Range)
    
  Dim rngB As Range
  Set rngB = Intersect(Target, Range("B:B"))
  If Not rngB Is Nothing Then
    If WorksheetFunction.CountIf(Range("B:B"), rngB.Cells(1)) > 1 Then
  
      MsgBox "Duplicate Entry Is Not Allowed", vbCritical, "Duplicate Entry"
      Application.EnableEvents = False
      Target.Value = ""
      Target.Select
      Application.EnableEvents = True
    End If
  End If

End Sub

 

[abdelfattah]

Deleted

 

[Alex Blakenburg]

I think he means column A,B together .

The code will handle that ie copying multiple cells on the same row. It will only partially handle copying or entering multiple values at once in column B.

 

[iffi]

in this case will not show message based on the code!

i have attached an image for the reference.

 

[iffi]

Give this a try:
Note: If you copy/change multiple cells in column B it will only test the first one. If you want to test them all it will take more code. Another option would be to give an error message if you copy/change multiple cells.

Private Sub Worksheet_Change(ByVal Target As Range)
   
  Dim rngB As Range
  Set rngB = Intersect(Target, Range("B:B"))
  If Not rngB Is Nothing Then
    If WorksheetFunction.CountIf(Range("B:B"), rngB.Cells(1)) > 1 Then
 
      MsgBox "Duplicate Entry Is Not Allowed", vbCritical, "Duplicate Entry"
      Application.EnableEvents = False
      Target.Value = ""
      Target.Select
      Application.EnableEvents = True
    End If
  End If

End Sub

Thank You So Much Alex Blakenburg Sir, it is working perfectly fine now. i have tested it in multiple ways by copying multiple cells along with restricted column B, no more error pop up msg. Thanks once again

 

[Alex Blakenburg]

You're welcome. Glad we could help.