Removing duplicates

excelledsoftware · #1 05-25-2015, 03:13 PM

Ok it has been over an hour with no reply so I am submitting the code that I wrote for this. This code will place a result in column B next to the value in Column A.

I have written 2 codes. One that will identify every duplicate to where you could sort and filter to identify which ones to remove and then another code that will identify just the duplicates. Meaning that if cell A3 has Jacob Parkar and cell A5 and A6 has Jacob Parkar or Parkar Jacob then only cells A5 and A6 will be identifed as duplicates. The only issue with this is that you may want the name with the last name starting as the original so play around with each and see which one works best.

As with all code be sure to back up your workbook and save before running.

Code:

Sub CheckAllDuplicates()
  'Checks each name to see if there are duplicates
  Dim ws As Worksheet, CheckRow As Long, FirstName As String, LastName As String
  Dim LastRow As Long, NameString As String, CheckName As String, CheckString As String
  Dim Counter As Integer
  
  'Set the references
  Set ws = ThisWorkbook.Worksheets(1)
  LastRow = ws.Range("A2").End(xlDown).Row
  For CheckRow = 2 To LastRow
    CheckString = ws.Range("A" & CheckRow).Value
    CheckName = "<" & CheckString & ">"
    FirstName = Mid(CheckString, 1, InStr(1, CheckString, " ") - 1)
    LastName = Mid(CheckString, Len(FirstName) + 2)
    'NameString = NameString & "<" & FirstName & " " & LastName & ">"
    NameString = NameString & "<" & LastName & " " & FirstName & ">"
  Next CheckRow
  For CheckRow = 2 To LastRow
    CheckString = ws.Range("A" & CheckRow).Value
    CheckName = "<" & CheckString & ">"
    Counter = 0
    Counter = WorksheetFunction.CountIf(ws.Range("A2" & ":A" & LastRow), CheckString)
    If InStr(1, NameString, CheckName) Then
      Counter = Counter + 1
    End If
    If Counter <> 1 Then
      Range("B" & CheckRow).Value = "Duplicate"
    End If
  Next CheckRow
  
End Sub

This one will show ONLY duplicates

Code:



Sub CountNameDuplicates()
  'Checks each name to see if there are duplicates
  Dim ws As Worksheet, CheckRow As Long, FirstName As String, LastName As String
  Dim LastRow As Long, NameArray() As String, CheckName As String, CheckString As String
  Dim Counter As Integer, arr As Long
  
  'Set the references
  Set ws = ThisWorkbook.Worksheets(1)
  LastRow = ws.Range("A2").End(xlDown).Row
  ReDim NameArray(2 To LastRow) As String
  For CheckRow = 2 To LastRow
    CheckString = ws.Range("A" & CheckRow).Value
    CheckName = "<" & CheckString & ">"
    FirstName = Mid(CheckString, 1, InStr(1, CheckString, " ") - 1)
    LastName = Mid(CheckString, Len(FirstName) + 2)
    'NameString = NameString & "<" & FirstName & " " & LastName & ">"
    NameArray(CheckRow) = "<" & LastName & " " & FirstName & ">"
  Next CheckRow
  For CheckRow = 2 To LastRow
    CheckString = ws.Range("A" & CheckRow).Value
    CheckName = "<" & CheckString & ">"
    Counter = 0
    Counter = WorksheetFunction.CountIf(ws.Range("A2" & ":A" & CheckRow), CheckString)
    'Check the array
    For arr = 2 To CheckRow
      If NameArray(arr) = CheckName Then
        Counter = Counter + 1
        Exit For 'no need to grab more
      End If
    Next arr
    'Check
    If Counter <> 1 Then
      Range("B" & CheckRow).Value = "Duplicate"
    End If
  Next CheckRow
End Sub

any questions please let me know.

To Bruno,

I appreciate the code that you wrote and effort you put forth. Charles and I were just unaware that you were going to provide a solution. I have had a time where I posted something without looking at the replies and caused unnecessary work for the person that was already working on it. Please let me know if you have any concerns regarding my comments.

Thanks so much.

Bruno Campanini · #2 05-25-2015, 04:21 PM

No concerns at all!
I just noted the bug you mentioned and the non-ability of my code to discover
names like:
Juan Carlos Primero -- Juan Primero Carlos
aa bb cc dd ee ff gg -- ff gg cc aa bb ee dd
and so on.
Then this new code:
=========================
Public Sub Test()
Dim k As Long, Split_1, Split_2
Dim h, i, j, n, SR As Range
Set SR = [Sheet1!A2:A26]
k = 1
For Each i In Range(SR(1), SR(SR.Count - 1))
k = k + 1
Split_1 = Split(i, " ")
For Each j In Range(i(k), SR(SR.Count))
Split_2 = Split(j, " ")
If UBound(Split_1) = UBound(Split_2) Then
k = 0
For Each h In Split_1
For Each n In Split_2
If h = n Then
k = k + 1
End If
Next
If k = UBound(Split_1) + 1 Then
MsgBox i & " " & j & vbCrLf & _
i.Address & " " & j.Address
End If
Next
End If
Next
k = 1
Next
End Sub
======================

Your opinion would be much appreciated

Bruno

excelledsoftware · #3 05-25-2015, 08:43 PM

Quote:

Originally Posted by Bruno Campanini

No concerns at all!
I just noted the bug you mentioned and the non-ability of my code to discover
names like:
Juan Carlos Primero -- Juan Primero Carlos
aa bb cc dd ee ff gg -- ff gg cc aa bb ee dd
and so on.
Then this new code:
=========================
Public Sub Test()
Dim k As Long, Split_1, Split_2
Dim h, i, j, n, SR As Range
Set SR = [Sheet1!A2:A26]
k = 1
For Each i In Range(SR(1), SR(SR.Count - 1))
k = k + 1
Split_1 = Split(i, " ")
For Each j In Range(i(k), SR(SR.Count))
Split_2 = Split(j, " ")
If UBound(Split_1) = UBound(Split_2) Then
k = 0
For Each h In Split_1
For Each n In Split_2
If h = n Then
k = k + 1
End If
Next
If k = UBound(Split_1) + 1 Then
MsgBox i & " " & j & vbCrLf & _
i.Address & " " & j.Address
End If
Next
End If
Next
k = 1
Next
End Sub
======================

Your opinion would be much appreciated

Bruno

I would be happy to lend my opinion. Everyone has their own coding style and I can see you have your own. I will say that the variable names are very difficult to understand but they work for you and if you are the only person that needs to understand your code you are just fine with that.

I absolutely love how you used the Split function to extract out the first and last name. Brilliant I of course used 2 mids but it would have been much easier to use your method.

The first code fixed the issue it displayed a msgbox identifying the duplicates. The next code went a step further by deleting the entry right out and not actually deleting the entire row (Good call on that) the only issue I ever have with code deleting data is if there was some reason the user needed to validate what the code did. I am confident that your code works but users may want to see the data to delete before they actually do so. I learned a good amount from your code and the techniques you did. The last bit of feed back is to place any code in the code brackets. use [ then "code" then another ] without the quotes then to end your code tag use [ then /code then antoher ] This is very very important as it will maintain your indentation and make things more consistent.

Keep up the great work.

Thanks

saurabhlotankar · #4 05-26-2015, 12:11 AM

Hello Folks,

Both codes are working perfectly fine. Thank you so much for such a quick turn around.

Once again thanks a ton to both excelledsoftware and Bruno Campanini for your help.

Have a great day ahead guys.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Extract duplicates in table	goran.c	Excel	0	01-21-2015 12:47 AM
Adding duplicates as comments	mnut	Excel Programming	1	10-17-2014 10:05 PM
Mail duplicates	mixy	Outlook	0	02-10-2011 12:54 AM
Inbox and subfolder duplicates	JoJo	Outlook	1	01-28-2011 04:39 PM
sum of duplicates	zxmax	Excel	1	09-29-2006 08:29 PM