trying to create vba that extracts names and compares them

[johnmerlino]

Hey all,

I'm having a little difficulty with a vba macro I am creating in excel.

Basically, item in column A may also appear in column B. I want the one with the greatest length in column C (In other words, Jennifer T Tamashiro is the same person as Tamashiro, Jennifer but since the first has a T middle initial, I would like to preserve that in column C and not Tamashiro, Jennifer) . However, if it does not appear in column B, then since there is njothing to compare, so for ones where the first and last names don't match a cell in column B or a cell in column A, I would like that output in Column C. Now there is one special case. Some names in column B will have something like: In trust of AKA Stephen T Smith, for example. In that case, I want to strip the comma at end and extract to the right of AKA so I only get the name and then do a comparison with the other column to see if the first and last name are the same and if so keep the one with middle initial. Also note that the ones in B always have last comma first except for the ones with AKA are first middle last. I started building the macro in VBA, had a little assistance, but still it's not right. It doesn't pull unique names in column c and it pulls all names in column C as first middle last rather than last first middle. Also on some instances it cuts away a portion of the last name I think. Here's an example of what I would like to have:

JENNIFER T TAMASHIRO      TAMASHIRO,  JENNIFER
JORGE J GARCIA	              STANIC,  ZORAN
Jamie Smith	                      In honor of AKA Jamie L Smith
	
Based on above example, what I would like in column C:	
TAMASHIRO JENNIFER T	
GARCIA JORGE J	
ZORAN STANIC	
Smith Jamie L

Here's the macro that is causing problems:

Option Explicit
Sub ParseNames()
    Dim AKA_Pos     As Long, _
        ctrl        As Long, _
        LastRow     As Long, _
        TestCell    As Range, _
        NewString   As String, _
        Fragments   As Variant
        
    LastRow = Cells(Rows.Count, 1).End(xlUp).Row

    For Each TestCell In Range("A1:A" & LastRow)
    
        AKA_Pos = InStr(UCase(TestCell.Value), " AKA ") + 5
        
        Fragments = Split(Mid(TestCell.Value, AKA_Pos), " ")
        
        For ctrl = 0 To UBound(Fragments)
            Fragments(ctrl) = WorksheetFunction.Substitute(Fragments(ctrl), ",", "")
        Next ctrl
        
        NewString = Fragments(UBound(Fragments))
    
        For ctrl = 0 To UBound(Fragments) - 1
            NewString = NewString & " " & Fragments(ctrl)
        Next ctrl
        
        NewString = Trim(NewString)
        Select Case Len(NewString) > Len(Cells(TestCell.Row, "B").Value)
            Case Is = True
                Cells(TestCell.Row, "C").Value = NewString
            
            Case Is = False
                Cells(TestCell.Row, "C").Value = Cells(TestCell.Row, "B").Value
        End Select
    Next TestCell
End Sub

Thanks for response

 

[AlphaFrog]

Sub ParseNames2()
        
    Dim Dict As Object
    Dim v As Variant, r As Long, Lastrow As Long
    Dim cell As Range
    Dim strName As String, strNameFull As String
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = TextCompare

    ' Parse column A names
    ' Firstname (optional middle initial) Lastname
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For Each cell In Range("A1:A" & LastRow)
        v = Split(Trim(StrConv(cell.Value, vbProperCase)))
        strName = v(UBound(v)) & ", " & Split(v(0), ",")(0)
        If UBound(v) > 1 Then
            strNameFull = strName & " " & v(1)
        Else
            strNameFull = strName
        End If
        If Dict.Exists(strName) Then
             If Len(Dict.Item(strName)) < Len(strNameFull) Then Dict.Item(strName) = strNameFull
        Else
            Dict.Add strName, strNameFull
        End If
    Next cell
    
    ' Parse column B names
    ' Lastname, Firstname (optional middle initial) except for AKA
    LastRow = Range("B" & Rows.Count).End(xlUp).Row
    For Each cell In Range("B1:B" & LastRow)
        If InStr(1, cell, " AKA ", 1) Then
            strName = Mid(cell.Value, InStr(1, cell, " AKA ", 1) + 5)
            v = Split(Trim(StrConv(strName, vbProperCase)))
            strName = v(UBound(v)) & ", " & v(0)
        Else
            v = Split(Trim(StrConv(cell.Value, vbProperCase)))
            strName = Split(v(0), ",")(0) & ", " & v(UBound(v))
        End If
        If UBound(v) > 1 Then
            strNameFull = Trim(strName & " " & v(1))
        Else
            strNameFull = strName
        End If
        If Dict.Exists(strName) Then
             If Len(Dict.Item(strName)) < Len(strNameFull) Then Dict.Item(strName) = strNameFull
        Else
            Dict.Add strName, strNameFull
        End If
    Next cell
    
    ' Write parsed unique names to column C
    r = 1  ' start row
    Columns("C").ClearContents
    For Each v In Dict.Items
        Range("C" & r).Value = v
        r = r + 1
    Next v
    Set Dict = Nothing

End Sub

 

[johnmerlino]

Thanks for response. What you posted is giving me the following error:

Run time error ‘9’:
Subscript out of range

And highlights the following:

strName = v(UBound(v)) & ", " & Split(v(0), ",")(0)

Not sure why.

 

[AlphaFrog]

There's probably some blank cells in between the filled cells. Blanks will cause an error.

Try this...

Sub ParseNames2()
        
    Dim Dict As Object
    Dim v As Variant, r As Long, Lastrow As Long
    Dim cell As Range
    Dim strName As String, strNameFull As String
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = TextCompare

    ' Parse column A names
    ' Firstname (optional middle initial) Lastname
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    For Each cell In Range("A1:A" & Lastrow)
        [COLOR="Red"]If Not IsEmpty(cell) Then[/COLOR]
        v = Split(Trim(StrConv(cell.Value, vbProperCase)))
        strName = v(UBound(v)) & ", " & Split(v(0), ",")(0)
        If UBound(v) > 1 Then
            strNameFull = strName & " " & v(1)
        Else
            strNameFull = strName
        End If
        If Dict.Exists(strName) Then
             If Len(Dict.Item(strName)) < Len(strNameFull) Then Dict.Item(strName) = strNameFull
        Else
            Dict.Add strName, strNameFull
        End If
        [COLOR="Red"]End If[/COLOR]
    Next cell
    
    ' Parse column B names
    ' Lastname, Firstname (optional middle initial) except for AKA
    Lastrow = Range("B" & Rows.Count).End(xlUp).Row
    For Each cell In Range("B1:B" & Lastrow)
        [COLOR="Red"]If Not IsEmpty(cell) Then[/COLOR]
        If InStr(1, cell, " AKA ", 1) Then
            strName = Mid(cell.Value, InStr(1, cell, " AKA ", 1) + 5)
            v = Split(Trim(StrConv(strName, vbProperCase)))
            strName = v(UBound(v)) & ", " & v(0)
        Else
            v = Split(Trim(StrConv(cell.Value, vbProperCase)))
            strName = Split(v(0), ",")(0) & ", " & v(UBound(v))
        End If
        If UBound(v) > 1 Then
            strNameFull = Trim(strName & " " & v(1))
        Else
            strNameFull = strName
        End If
        If Dict.Exists(strName) Then
             If Len(Dict.Item(strName)) < Len(strNameFull) Then Dict.Item(strName) = strNameFull
        Else
            Dict.Add strName, strNameFull
        End If
        [COLOR="Red"]End If[/COLOR]
    Next cell
    
    ' Write parsed unique names to column C
    r = 1  ' start row
    Columns("C").ClearContents
    For Each v In Dict.Items
        Range("C" & r).Value = v
        r = r + 1
    Next v
    Set Dict = Nothing

End Sub

 

[johnmerlino]

Thanks a lot so much for your responses. Your macro substantially improved what I had. One little thing though. This macro produces first name comma last name middle name:

Jose, Salazar J
Michael, Sobel

But I was hoping for last name first name middle name:

Salazar Jose J
Sobel Michael

Thanks for response.

 

[AlphaFrog]

The macro produces
Lastname, Firstname Midname

I can easily remove the comma.

 

[johnmerlino]

Thanks for response. I tried removing the commas myself but I think I misunderstood the macro because while it removed commas for some it didnt do it for all of them.

 

[AlphaFrog]

Sub ParseNames2()
        
    Dim Dict As Object
    Dim v As Variant, r As Long, Lastrow As Long
    Dim cell As Range
    Dim strName As String, strNameFull As String
    
    Set Dict = CreateObject("Scripting.Dictionary")
    Dict.CompareMode = TextCompare

    ' Parse column A names
    ' Firstname (optional middle initial) Lastname
    Lastrow = Range("A" & Rows.Count).End(xlUp).Row
    For Each cell In Range("A1:A" & Lastrow)
        If Not IsEmpty(cell) Then
        v = Split(Trim(StrConv(cell.Value, vbProperCase)))
        strName = v(UBound(v)) & " " & Split(v(0), ",")(0)
        If UBound(v) > 1 Then
            strNameFull = strName & " " & v(1)
        Else
            strNameFull = strName
        End If
        If Dict.Exists(strName) Then
             If Len(Dict.Item(strName)) < Len(strNameFull) Then Dict.Item(strName) = strNameFull
        Else
            Dict.Add strName, strNameFull
        End If
        End If
    Next cell
    
    ' Parse column B names
    ' Lastname, Firstname (optional middle initial) except for AKA
    Lastrow = Range("B" & Rows.Count).End(xlUp).Row
    For Each cell In Range("B1:B" & Lastrow)
        If Not IsEmpty(cell) Then
        If InStr(1, cell, " AKA ", 1) Then
            strName = Mid(cell.Value, InStr(1, cell, " AKA ", 1) + 5)
            v = Split(Trim(StrConv(strName, vbProperCase)))
            strName = v(UBound(v)) & " " & v(0)
        Else
            v = Split(Trim(StrConv(cell.Value, vbProperCase)))
            strName = Split(v(0), ",")(0) & " " & v(UBound(v))
        End If
        If UBound(v) > 1 Then
            strNameFull = Trim(strName & " " & v(1))
        Else
            strNameFull = strName
        End If
        If Dict.Exists(strName) Then
             If Len(Dict.Item(strName)) < Len(strNameFull) Then Dict.Item(strName) = strNameFull
        Else
            Dict.Add strName, strNameFull
        End If
        End If
    Next cell
    
    ' Write parsed unique names to column C
    r = 1  ' start row
    Columns("C").ClearContents
    For Each v In Dict.Items
        Range("C" & r).Value = v
        r = r + 1
    Next v
    Set Dict = Nothing

End Sub