VBA Name Matching

[frabulator]

I have a list of names in this format:

Doe, John E

and a list of names in this format:

John Doe

I am looking for a way to either A). Match the names and see which names show up on both list, or B). Compare the names in the columns to see which has the closest match (as in, 7 characters, and all 7 of those characters appear in each the same number of times, therefore pretty sure they are the same person).

Any easy way of doing this in VBA?

 

[frabulator]

Never mind. After typing my question in, I realized I stepped myself through the issue.

For anyone wondering, it is called Fuzzy Matching. Basically take your lower count name and compare it to the higher count name. Higher the match the better your changes of a match is.

Sub RunCode

'... unneeded code

    Dim PointValue As Integer
    PointValue = 100
    Dim NoGrade As Integer
    NoGrade = 0
   
    Dim Score As Integer
   
    Dim NameIC As String
    Dim NameG As String
    Dim Graded As Boolean
   
   
   
    'loop and make
    For i = 2 To IC_List
        Score = 0
        NameIC = ActiveSheet.Cells(i, 1).Value
        ActiveSheet.Cells(i, 5).Value = NameIC
        Graded = False
       
        For g = 2 To GoogleTurnedIn_List
            NameG = ActiveSheet.Cells(g, 3).Value
            Score = CharacterMatchScore(NameG, NameIC)
            Score = Math.Round((Score / Len(NameG)) * 100, 0)
            If Score > 90 Then
                ActiveSheet.Cells(i, 6).Value = PointValue
                Graded = True
                Exit For
               
            End If
        Next
       
        If Graded = False Then ActiveSheet.Cells(i, 6).Value = NoGrade
    Next
   
End Sub

Function CharacterMatchScore(Name1 As String, Name2 As String) As Integer
    Dim CharDict As Object
    Set CharDict = CreateObject("Scripting.Dictionary")
   
    Dim i As Integer, Score As Integer
    Dim ch As String
   
    ' Populate dictionary with Name1 characters
    For i = 1 To Len(Name1)
        ch = Mid(Name1, i, 1)
        If Not CharDict.Exists(ch) Then
            CharDict.Add ch, 1
        Else
            CharDict(ch) = CharDict(ch) + 1
        End If
    Next i
   
    ' Compare Name2 characters with Name1's dictionary
    For i = 1 To Len(Name2)
        ch = Mid(Name2, i, 1)
        If CharDict.Exists(ch) And CharDict(ch) > 0 Then
            Score = Score + 1
            CharDict(ch) = CharDict(ch) - 1
        End If
    Next i
   
    CharacterMatchScore = Score
End Function

Sub FuzzyMatchNames()
    Dim i As Integer, j As Integer
    Dim ws As Worksheet
    Dim Name1 As String, Name2 As String
    Dim Score As Integer
   
    Set ws = ThisWorkbook.Sheets(1)

    For i = 1 To ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
        Name1 = ws.Cells(i, 1).Value
       
        For j = 1 To ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
            Name2 = ws.Cells(j, 2).Value
            Score = CharacterMatchScore(Name1, Name2)
           
            ws.Cells(i, 3).Value = Score
        Next j
    Next i
End Sub