Microsoft Office Forums - View Single Post

excelledsoftware · 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.