Finding duplicates in a column, prompt user then delete the current one

Hi there,

I would like to have few lines to code to let Excel first find duplicates against column 1 when users enter new record. If a duplicate is found, then a pop-up window saying duplicate is found or something like that and then have Excel delete the current line so that we don't have to manually delete it by right-clicking then hit "Delete".

The list goes on forever so I thought I should use a macro in worksheet change event, but i don' tknow how to get started.

Is this possible?

Please see the attached file.

Thank you

How about something like this?

This just deletes the cell contents as your file is empty and I am not sure if you want the entire row deleted or entire column deleted.

Option Explicit
Sub d()
    Dim Mbox As String
    Dim LR As Long, i As Long, found As Range
    Application.ScreenUpdating = False
     On Error Resume Next
        LR = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 1 To Cells(Rows.Count, 1).End(xlUp).Row
        Set found = Range("a:a").Find(what:=Cells(i, "b"), LookIn:=xlValues, LookAt:=xlWhole)
      If Not found Is Nothing Then
            Mbox = MsgBox("Duplicate Found, do you want to delete duplicate", vbYesNo, "Duplicate")
        If Mbox = vbYes Then
          Cells(i, "b").EntireRow.Delete
        Else
        End If
      End If
    Next i
    
    Set found = Nothing
    Application.ScreenUpdating = True
End Sub

Originally Posted by Lifeseeker

Clear cell contents if the next value you enter in col a has a duplicate.

I had already modified the code to delete the entire row. You can have it delete from cells 1- 60 , but that will leave a blank row?

I don't understand what you are saying in this sentence?

Hey Winon,

Try this and see if it works for you?

Option Explicit
Sub d()
    Dim Mbox As String
    Dim LR As Long, i As Long, found As Range
    Application.ScreenUpdating = False
     On Error Resume Next
        LR = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Set found = Range("a:a").Find(what:=Cells(i, "b"), LookIn:=xlValues, LookAt:=xlWhole)
      If Not found Is Nothing Then
            Mbox = MsgBox("Duplicate Found, do you want to delete entire row contents?", vbYesNo, "Duplicate")
        If Mbox = vbYes Then
          Rows(i).ClearContents
        Else
          Mbox = vbNo
        Resume Next
        End If
      End If
    Next i
    
    Set found = Nothing
    Application.ScreenUpdating = True
End Sub

@ JapanDave,

Thank you very much for your time and effort. The code Clears the whole Row though, while I am trying to get it to clear only the range- Colums A through to Column i. This has been bugging me for a long time now.

I am not sure I understand.

Eg, if you find a duplicate from what column to what column in what row do you want to clear?

OK, how about this?

Option Explicit
Sub d()
    Dim Mbox As String
    Dim LR As Long, i As Long, found As Range
    Application.ScreenUpdating = False
     On Error Resume Next
        LR = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Set found = Range("a:a").Find(what:=Cells(i, "b"), LookIn:=xlValues, LookAt:=xlWhole)
      If Not found Is Nothing Then
            Mbox = MsgBox("Duplicate Found, do you want to delete duplicate", vbYesNo, "Duplicate")
        If Mbox = vbYes Then
          Range(Cells(i, 1), Cells(i, 9)).ClearContents
        Else
          Mbox = vbNo
        Resume Next
        End If
      End If
    Next i
    
    Set found = Nothing
    Application.ScreenUpdating = True
End Sub

Hey Winon,

Try this and see if it is what you are after?

Option Explicit
Sub d()
    Dim Mbox As String
    Dim LR As Long, i As Long, found As Range
    Application.ScreenUpdating = False
     On Error Resume Next
        LR = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
        Set found = Range("a:a").Find(what:=Cells(i, "b"), LookIn:=xlValues, LookAt:=xlWhole)
          If found <> vbNullString Then
            If Not found Is Nothing Then
                  Mbox = MsgBox("Duplicate Found, do you want to delete duplicate", vbYesNo, "Duplicate")
              If Mbox = vbYes Then
                Range(Cells(i, 1), Cells(i, 9)).ClearContents
              Else
                Mbox = vbNo
              Resume Next
              End If
            End If
          End If
    Next i
    
    Set found = Nothing
    Application.ScreenUpdating = True
End Sub

Thanks Winon, and thanks for the rep. Let me know If I can help you out further?

Lifeseeker, if this thread is solved, please go to advance edit and mark it solved.

How is the Main worksheet and sub worksheet linked? At present they are not linked.

Lifeseeker,
OK, so you manually input data into both sheets and they are not linked. Got that.

I don't know what you want deleted, so for the time being this macro deletes the duplicate you just entered (Tell me if you want it another way?). Enter 123 in cell A3 and see if this is what you are after?

Private Sub Worksheet_Change(ByVal Target As Range)

 Dim ws As Worksheet, ws1 As Worksheet
 Dim Mbox As String, cVal As Range, LR1 As Long
 Dim LR As Long, i As Long, found As Range, cel As Range, rng As Range
 Dim cell_to_test As Range
 
     Set ws1 = Sheets("Main")
     LR1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
     
    If Not Intersect(Target, Range("A" & LR1)) Is Nothing Then
          
        Application.ScreenUpdating = 0
        Application.EnableEvents = 0
           Set ws = Sheets("Sub")
           On Error Resume Next
              LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
              Set rng = ws.Range("A2:A" & LR)
              
              Set cVal = ws1.Cells(LR1, 1)
                  For Each cel In rng
                      Set found = rng.Find(what:=cVal, LookIn:=xlValues, LookAt:=xlWhole)
                          If found <> vbNullString Then
                            If Not found Is Nothing Then
                                 Mbox = MsgBox("Duplicate Found, do you want to delete duplicate", vbYesNo, "Duplicate")
                              If Mbox = vbYes Then
                               cVal.ClearContents
                              Else
                               Resume Next
                              End If
                            End If
                          End If
                  Next cel
      End If
          Set found = Nothing
        Application.EnableEvents = 1
        Application.ScreenUpdating = 1
End Sub

Edit: The system is not allowing me to upload a file, paste this in the worksheet module for "Main".
Edit* it worked. See file

Try this,
It deletes the entire row in the Sub worksheet.

Private Sub Worksheet_Change(ByVal Target As Range)

 Dim ws As Worksheet, ws1 As Worksheet
 Dim Mbox As String, cVal As Range, LR1 As Long
 Dim LR As Long, i As Long, found As Range, cel As Range, rng As Range
 Dim del As Variant
 
     Set ws1 = Sheets("Main")
     LR1 = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
     
    If Not Intersect(Target, Range("A" & LR1)) Is Nothing Then
          
        Application.ScreenUpdating = 0
        Application.EnableEvents = 0
           Set ws = Sheets("Sub")
           On Error Resume Next
              LR = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
              Set rng = ws.Range("A2:A" & LR)
              
              Set cVal = ws1.Cells(LR1, 1)
                  For Each cel In rng
                      Set found = rng.Find(what:=cVal, LookIn:=xlValues, LookAt:=xlWhole)
                          If found <> vbNullString Then
                            If Not found Is Nothing Then
                                 Mbox = MsgBox("Duplicate Found, do you want to delete duplicate", vbYesNo, "Duplicate")
                              If Mbox = vbYes Then
                                del = found.Address
                                ws.Range(del).EntireRow.Delete
                              Else
                               Resume Next
                              End If
                            End If
                          End If
                  Next cel
      End If
          Set found = Nothing
        Application.EnableEvents = 1
        Application.ScreenUpdating = 1
End Sub

Great I could have helped.

Dave