Another split text question

[baigrieja]

Help, I'm pulling my hair out on this one.

I have inherited a list of name, but need to split out the Title, Initials and Surname into three separate fields. Here is a small sample

Mr A D Smith
A & D Smith
A & D Smith & Sons
A D & Mrs A Smith
Miss A D Smith
Dr A D Smith
Ms A D Smith
Dr A D Smith & Partners
A D Smith & B F Brown

In each case, surname should be Smith, Smith & Sons, Smith & Partners or Smith & B F Brown.

If the field contains a Title, but not at the start i.e. A D & Mrs A Smith, then the initial field should be blank and the title field should contain A D & Mrs A.

Finally, the initials should retain any spaces between characters.

I have a couple of VBA functions that perform well on the basic entries, but these do not handle surnames with spaces in them i.e. Smith & Sons and also put the initials without spaces.

Can anyone out there solve this?

[baigrieja]

The code being used at present is

Function get_initials(fullname)
get_initials = ""
rest = fullname
part_initials = ""
If InStr(rest, " ") > 2 Then
rest = Mid(rest, InStr(rest, " ") + 1)
End If
Do While InStr(rest, " ") > 0
part_initials = part_initials & Left(rest, 1)
rest = Mid(rest, 3)
Loop
get_initials = part_initials
End Function

Function get_surname(fullname)
get_surname = Mid(fullname, InStr(fullname, " ") + 1)
reduce = Mid(fullname, InStr(fullname, " ") + 1)
Do While InStr(reduce, " ") > 0
reduce = Mid(reduce, InStr(reduce, " ") + 1)
Loop
get_surname = reduce
End Function

Function get_title(fullname)
Dim rest
get_title = ""
If InStr(fullname, " ") > 2 Then
get_title = Left(fullname, InStr(fullname, " "))
End If
End Function