09 January 2014

VBA Name Parser

There are plenty of simple name parsers out there, but I needed one that would handle titles, suffixes, prepositions / particles (I'm no grammar expert), etc. This is what I hacked together for a VBA function in Excel:

(Things could be cleaned up more if VBA had better array functions built in, specifically pop and shift...)

Pass in "n" the name to be parsed and "piece," which is an integer 1 thru 5 for:
1: title
2: first name
3: middle name(s)
4: last name
5: suffix


Function Namify(n, piece) as String
    Dim Pieces() As String
    Pieces = Split(n)
    
    Dim Letters() As String
    
    Dim Length As Integer
    Length = UBound(Pieces) + 1
    
    Namify = ""
    If Length < 1 Then Exit Function
    
    If piece = 1 And IsTitle(Pieces(0)) Then
        Namify = Pieces(0)
    ElseIf piece = 5 And IsSuffix(Pieces(Length - 1)) Then
        Namify = Pieces(Length - 1)
    ElseIf Length = 1 Then
        If piece = 2 Then Namify = Pieces(0)
    ElseIf Length = 2 Then
    
        If IsTitle(Pieces(0)) Then
            If piece = 4 Then Namify = Pieces(1)
            Exit Function
        ElseIf IsParticle(Pieces(0)) Then
            If piece = 4 Then Namify = Pieces(0) & " " & Pieces(1)
            Exit Function
        End If
        
        'look for joined abbreviations
        Letters = Split(Pieces(0), ".")
        If UBound(Letters) > 1 Then
        
            If piece = 2 Or piece = 3 Then
                Namify = Letters(piece - 2) & "."
            ElseIf piece = 4 Then
                Namify = Pieces(1)
            End If
            
        'first name
        ElseIf piece = 2 Then
            Namify = Pieces(0)
        ElseIf piece = 4 And Not IsSuffix(Pieces(1)) Then
            Namify = Pieces(1)
        ElseIf piece = 5 And IsSuffix(Pieces(1)) Then
            Namify = Pieces(1)
        End If
        
    ElseIf Length = 3 Then
    
        If IsTitle(Pieces(0)) Then
            
            Namify = Namify(Pieces(1) & " " & Pieces(2), piece)
            
        ElseIf IsSuffix(Pieces(2)) Then
        
            If piece = 5 Then
                Namify = Pieces(2)
            Else
                Namify = Namify(Pieces(0) & " " & Pieces(1), piece)
            End If
            
        ElseIf IsParticle(Pieces(1)) Then
            
            If piece = 2 Then
                Namify = Pieces(0)
            ElseIf piece = 4 Then
                Namify = Pieces(1) & " " & Pieces(2)
            End If
            
        ElseIf piece < 5 And piece > 1 Then
        
            Namify = Pieces(piece - 2)
        
        End If
        
    ElseIf Length = 4 Then
    
        If IsTitle(Pieces(0)) Then
        
            Namify = Namify(Pieces(1) & " " & Pieces(2) & " " & Pieces(3), piece)
        
        ElseIf IsSuffix(Pieces(3)) Then
            
            If piece = 5 Then
                Namify = Pieces(3)
            Else
                Namify = Namify(Pieces(0) & " " & Pieces(1) & " " & Pieces(2), piece)
            End If
            
        Else
        
            If piece = 2 Then
                Namify = Pieces(0)
            ElseIf piece = 3 Then
                If IsParticle(Pieces(2)) Then
                    If Not IsParticle(Pieces(1)) Then
                        Namify = Pieces(1)
                    End If
                ElseIf Not IsParticle(Pieces(1)) Then
                    Namify = Pieces(1) & " " & Pieces(2)
                End If
            ElseIf piece = 4 Then
                If IsParticle(Pieces(1)) Then
                    Namify = Pieces(1) & " " & Pieces(2) & " " & Pieces(3)
                ElseIf IsParticle(Pieces(2)) Then
                    Namify = Pieces(2) & " " & Pieces(3)
                Else
                    Namify = Pieces(3)
                End If
            End If
        
        End If
        
    ElseIf Length = 5 Then
        
        If IsTitle(Pieces(0)) Then
            Namify = Namify(Pieces(1) & " " & Pieces(2) & " " & Pieces(3) & " " & Pieces(4), piece)
        ElseIf IsSuffix(Pieces(4)) Then
            Namify = Namify(Pieces(0) & " " & Pieces(1) & " " & Pieces(2) & " " & Pieces(3), piece)
        Else
            If piece = 2 Then
                Namify = Pieces(0)
            ElseIf piece = 3 Then
                Namify = Pieces(1) & " " & Pieces(2)
                If Not IsParticle(Pieces(3)) Then
                    Namify = Namify & " " & Pieces(3)
                End If
            ElseIf piece = 4 Then
                If IsParticle(Pieces(3)) Then
                    Namify = Pieces(3) & " " & Pieces(4)
                Else
                    Namify = Pieces(4)
                End If
            End If
        End If
    
    ElseIf Length = 6 Then
        
        If IsTitle(Pieces(0)) Then
            Namify = Namify(Pieces(1) & " " & Pieces(2) & " " & Pieces(3) & " " & Pieces(4) & " " & Pieces(5), piece)
        ElseIf IsSuffix(Pieces(5)) Then
            Namify = Namify(Pieces(0) & " " & Pieces(1) & " " & Pieces(2) & " " & Pieces(3) & " " & Pieces(4), piece)
        End If
    End If
    
    ' clean up hanging commas
    If Right(Namify, 1) = "," Then
        Namify = Mid(Namify, 1, Len(Namify) - 1)
    End If
    
End Function

Function IsTitle(t As String) As Boolean
    Dim Titles As Variant
    Titles = Array("Mr", "Mr.", "Ms", "Ms.", "Mrs", "Mrs.", "Dr", "Dr.", "Sir", "Miss")
    IsTitle = (UBound(Filter(Titles, t)) > -1)
End Function

Function IsSuffix(s As String) As Boolean
    Dim Suffixes As Variant
    Suffixes = Array("II", "III", "IV", "V", "Jr", "Jr.", "Sr", "Sr.", "PhD", "Ph.D", "MD", "M.D.", "PE", "P.E.", "Ctech", "P.Eng.")
    IsSuffix = (UBound(Filter(Suffixes, s)) > -1)
End Function

Function IsParticle(p As String) As Boolean
    Dim Particles As Variant
    Particles = Array("de", "De", "le", "Le", "la", "La", "du", "Du", "von", "Von", "van", "Van", "O")
    IsParticle = (UBound(Filter(Particles, p)) > -1)
End Function