(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