Text to columns - Uniform response with different numbers of Spaces

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: