Hi! I am trying to separate suffix/first/last name into different column.
Currently I work with different formats:
Mr John Smith
Mr and Mrs. Smith
Mr Smith
Dr and Ms Smith
Mr John and Mrs Jane Smith
Is there a way to do this without having going to Text to Column- Delimited-
and separate everything by a space and then putting it all back together?
Even something to just separate the last name or the last word in a column
would be very helpful. Thank you!!!
Parsing names is extraordinarily difficult because of all the variations.
The following VBA Macro may help, but it is not perfect.
It will generally separate out the
Title
Everything up to the Last Name
Last Name
Suffix
It can handle two titles of the type:
Dr and Ms
But it cannot handle a name like
Mr John and Mrs Jane Smith
That will get parsed as
Mr John and Mrs Jane Smith
The others will generally be OK.
Try it and see if it is of value.
To enter the macro, <alt-F11> opens the VB Editor. Ensure your project is
highlighted in the Project Explorer window, then Insert/Module and paste the
code below into the window that opens.
To use it, SELECT a single column range of cells. Then <alt-F8> opens the
Macro Dialog box. Select the ParseName macro and <RUN>.
As posted, it will parse the names into the adjacent cells. By making the
indicted change in the lOffset constant, you can overwrite the original -- but
before doing this, you should ensure the macro does what you want.
You can also overwrite the original by selecting the four adjacent columns, and
dragging them to the left.
=============================================
Option Explicit
Sub ParseName()
Dim c As Range
Dim sStr As String
Dim re As Object, mc As Object
Dim i As Long
'if lOffset = 1, first entry will go next to data
'if lOffset = 0, first entry will replace data
Const lOffset As Long = 1
Set re = CreateObject("vbscript.regexp")
re.IgnoreCase = True
re.Pattern = "^((Mrs|Mr|Ms|Miss|Dr)\.?(\s+(and|&)\s+(Mrs|Mr|Ms|Miss|Dr)" _
& "\.?)?)?\s*(.*?)\s*(\b[-\w]+\b)\s*(Jr|Sr|III|II|IV|MD|M\.D\.|PhD\.?)?\s*$"
For Each c In Selection
sStr = c.Value
If re.test(sStr) = True Then
Set mc = re.Execute(sStr)
Range(c(1, lOffset + 1), c(1, lOffset + 4)).ClearContents
c(1, lOffset + 1).Value = mc(0).submatches(0) 'Title
c(1, lOffset + 2).Value = mc(0).submatches(5) 'First and Middle
c(1, lOffset + 3).Value = mc(0).submatches(6) 'Last
c(1, lOffset + 4).Value = mc(0).submatches(7) 'Suffix
End If
Next c
End Sub
=======================================
--ron
