EXCEL - Check/ identify duplicate text between multiple rows AND on another sheet

Question

I have the first and last name of criminals in New York during the early 20th C. I have narrowed down the certain sector of crime I'm focusing on, but I want to cross-reference the names with the wider database to see if they have committed any other offences. The problem is, the first name and last name are in different cells. SO, the best I've been able to do so far is mark an 'X' if there is a match for the last name, and an 'X' in the column next to if there is a match for the first name. The problem with this is that while it narrows it down SLIGHTLY, there's lots of people that have the name 'Adam' for example, and lots with the last name 'Brown', so it doesn't show there's actually a match.

So spreadsheet 1 'S1', has a last name (e.g. Brown) in C2 and first name (e.g. John) in D2 while spreadsheet 2 'S2' has totally different names in C2 and D2, so I need to search through all the column of C and then D for a match.

Is there a way of writing a code for this? Any ideas?!

Answer 1

If a custom report is more convenient, the VBA code bellow needs an extra sheet

Assuming that your sheets are "Sheet1" (S1), "Sheet2" (S2), and Sheet3 (the report), the solution will generate on Sheet3 a list with all unique FirstName + LastName from S1 that have a match on S2

• Column B will show how many duplicates exist in S1
• Column C = First Name (S1)
• Column D = Last Name (S1)
• Column E will show how many duplicates exist in S2

Additional functionality:

If you click on any Name (First or Last) on S3 it will filter S1 and S2 for that name, similar to this:

---

S1

S2

---

Report (S3)

---

Clicking on "First3" (or "Last3") in S3, you'll get

S1

S2

---

The code:

Open VBA editor: Alt+F11

• Insert a new generic module: anywhere in the top-left pane right-click and select Insert -> Module
• In the new module (probably called Module1), right pane, paste the following code:

---

Module1 (total of 4 procedures):

---

Option Explicit

Public Sub FindMatches()
    Dim ws1 As Worksheet, ws2 As Worksheet, d1 As Object, d2 As Object

    Set ws1 = Sheet1
    Set ws2 = Sheet2
    Set d1 = ReadNames(ws1)
    Set d2 = ReadNames(ws2)

    If Not d1 Is Nothing And Not d2 Is Nothing Then MatchNames d1, d2
    Sheet3.Activate
End Sub

Private Function ReadNames(ByRef ws As Worksheet) As Object
    If Not ws Is Nothing Then
        Dim d As Object, ur As Variant, i As Long

        Set d = CreateObject("Scripting.Dictionary")
        d.CompareMode = TextCompare

        ur = ws.UsedRange.Columns("C:D") 'Read all names
        For i = LBound(ur) To UBound(ur)
            If Not d.Exists(ur(i, 1) & " " & ur(i, 2)) Then 'this keeps count of dupes
                d(ur(i, 1) & " " & ur(i, 2)) = 1
            Else
                d(ur(i, 1) & " " & ur(i, 2)) = d(ur(i, 1) & " " & ur(i, 2)) + 1
            End If
        Next
        Set ReadNames = d
    End If
End Function

---

'Generates list of unique names on Sheet3, for full names from Sheet1, found on Sheet2

Private Sub MatchNames(ByRef d1 As Object, d2 As Object)
    If Not d1 Is Nothing And Not d2 Is Nothing Then
        Dim ur As Variant, itm As Variant, i As Long, fl As Variant

        With Sheet3     'Or use Worksheets("Sheet3") 'or "Matches", or "Report", etc
            .UsedRange.EntireRow.Delete
            ur = .Range(.Cells(1, 2), .Cells(d1.Count, 5))
        End With
        ur(1, 1) = "Sheet1 Count":  ur(1, 4) = "Sheet2 Count"
        ur(1, 2) = "First Name":    ur(1, 3) = "Last Name"
        i = 2
        For Each itm In d1
            If d2.Exists(itm) Then
                ur(i, 1) = d1(itm)
                fl = Split(itm)
                ur(i, 2) = fl(0)
                ur(i, 3) = fl(1)
                ur(i, 4) = d2(itm)
                i = i + 1
            End If
        Next
        With Sheet3
            .Range(.Cells(1, 2), .Cells(d1.Count, 5)) = ur
            With .UsedRange.Columns
                .EntireColumn.AutoFit
                .HorizontalAlignment = xlCenter
            End With
        End With
    End If
End Sub

---

Public Sub FilterNames(ByRef ws As Worksheet, ByVal fName As String, lName As String)
    With ws.UsedRange
        .AutoFilter Field:=4, Criteria1:=lName
        .AutoFilter Field:=3, Criteria1:=fName
    End With
End Sub

---

Now, in the VBA editor double-click the item "Sheet3" (top left) to open its module and paste this code

---

"Sheet3" Module (1 procedure):

---

Option Explicit

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    If Target.CountLarge = 1 Then
        Dim lr As Long, fn As String, ln As String
        lr = Me.UsedRange.Rows.Count
        With Target
            If (.Row > 1 And .Row <= lr) And (.Column = 3 Or .Column = 4) Then
                fn = .Value2
                ln = .Offset(, 1).Value2
                If .Column = 4 Then
                    fn = .Offset(, -1).Value2
                    ln = .Value2
                End If
                FilterNames Sheet1, fn, ln
                FilterNames Sheet2, fn, ln
            Else
                If Sheet1.AutoFilterMode Then Sheet1.UsedRange.AutoFilter
                If Sheet2.AutoFilterMode Then Sheet2.UsedRange.AutoFilter
            End If
        End With
        Sheet1.Activate
    End If
End Sub

---

To execute the code

• double-click Module1 again
• place the mouse cursor anywhere in the top Sub FindMatches()
• press F5

Make sure that all sheets are named exactly "Sheet1", "Sheet2", and "Sheet3"

Hope this helps