Text to columns - Uniform response with different numbers of Spaces - excel

Question

I have a spreadsheet where column A is a list of names. Some of these names have titles (e.g., Mr John Doe, Miss Jane Doe, Mrs Jane Bloggs, Cllr Joe Bloggs etc) some of the names do not (just Joe Doe, John Bloggs, Jane Doe etc). I've been asked to split the names into three columns - Title, First Name, Last Name.
When I try the simple "text to columns", it's fine where there is a title, but where there isn't one, the first name defaults to the title column.
Is there a way to have the data split into the correct cells, or is it going to be a lot of manual work for someone?

Answer 1

You can use VBA to accomplish this.
You will create two different arrays. The first one is your raw data (your single column) preArr(), and your new array that will be written back to the worksheet postArr() that has been dimensioned for three columns ReDim postArr(..., 1 To 3).
First, test if the string from preArr(i, 1) contains known salutations. If it does, then you will add the first split string to postArr(, 1) - otherwise you won't add anything to this column.
Side Note: You can add additional salutations to this line:
.Pattern = "^(?:MRS?|MS|MIS+|CLLR|DR)\.?\s"
This is a regular expression, but just add another | separator for additional checks. I combined MR and MRS into one group, the ? makes the S optional in case you were wondering.
Here is the full program:
Option Explicit
Sub splitOnNames()
Dim preArr(), postArr(), ws As Worksheet, preRng As Range
Set ws = Selection.Parent
Set preRng = Selection
preArr = preRng.Value
If UBound(preArr, 2) > 1 Then
MsgBox "This can only be done on a single column!", vbCritical
Exit Sub
End If
ReDim postArr(LBound(preArr) To UBound(preArr), 1 To 3)
Dim i As Long, x As Long, tmpArr
For i = LBound(preArr) To UBound(preArr)
If preArr(i, 1) <> "" Then
tmpArr = Split(preArr(i, 1))
If testSalutation(preArr(i, 1)) Then
postArr(i, 1) = tmpArr(0)
postArr(i, 2) = tmpArr(1)
For x = 2 To UBound(tmpArr) 'Some last names have two names
postArr(i, 3) = Trim(postArr(i, 3) & " " & tmpArr(x))
Next x
Else
postArr(i, 2) = tmpArr(0)
For x = 1 To UBound(tmpArr) 'Some last names have two names
postArr(i, 3) = Trim(postArr(i, 3) & " " & tmpArr(x))
Next x
End If
Erase tmpArr
End If
Next i
With preRng
Dim postRng As Range
Set postRng = ws.Range(ws.Cells(.Row, .Column), _
ws.Cells(.Rows.Count + .Row - 1, .Column + 2))
postRng.Value = postArr
End With
End Sub
Private Function testSalutation(ByVal testStr As String) As Boolean
With CreateObject("VBScript.RegExp")
.IgnoreCase = True
.Pattern = "^(?:MRS?|MS|MIS+|CLLR|DR)\.?\s"
testSalutation = .Test(testStr)
End With
End Function
See it Live:

Answer 2

If I have to do this, then I use the 'Text to columns'. After that I sort by third column.
Now all rows having only 2 values are one after the other listed. I mark the first column for all this rows, press 'Ctrl + or' or click the right mouse and select 'insert cells'. Then you will be asked if you like to shift down or right. Select shift right and a cells are arranged as you like to have it.