I looked for a solution for this all over and can't find one that works or that I can modify to work. I have a list of full names that may or may not include a middle name, middle initial, and suffix. Using a VBA script, I need to parse the name into the appropriate, separate columns, as seen below. (Note - The suffix could include Jr, Jr., Sr, Sr., II, III, IV and V...for now)

The closest I've come is this code:(where "emptyRow" has already been determined as the first available row without data)

 Dim MyText As String
 Dim i As Integer
 Dim MyResult() As String
 
 MyText = Range("A" & emptyRow).Value
 MyResult = Split(MyText)

 For i = 0 To UBound(MyResult)
     Cells(emptyRow, i).Value = MyResult(i)
 Next I

BUT, it doesn't do anything about missing items, like middle name, or suffix.

Any ideas on how this could be made to work OR a different approach?

UPDATE:

So, here's what I came up with. I'm sure it could be prettier, but I THINK it works.

    MyResult = Split(MyText)
    i = UBound(MyResult)
    Cells(emptyRow, 1).Value = MyResult(0)
    If MyResult(i) = "Jr." Or MyResult(i) = "Jr" Or MyResult(i) = "Sr." Or MyResult(i) = "Sr" Or MyResult(i) = "II" Or MyResult(i) = "ii" Or MyResult(i) = "III" Or MyResult(i) = "IIi" Or MyResult(i) = "Iii" Or MyResult(i) = "IiI" Or MyResult(i) = "iii" Or MyResult(i) = "iIi" Or MyResult(i) = "iiI" Or MyResult(i) = "iII" Or MyResult(i) = "iI" Or MyResult(i) = "Ii" Or MyResult(i) = "IV" Or MyResult(i) = "V" Or MyResult(i) = "iv" Or MyResult(i) = "v" Or MyResult(i) = "Iv" Or MyResult(i) = "iV" Then
        If i = 5 Then
            Cells(emptyRow, 4).Value = MyResult(i)
            Cells(emptyRow, 3).Value = MyResult(3) & " " & MyResult(4)
            Cells(emptyRow, 2).Value = MyResult(1) & " " & MyResult(2)
            ElseIf i = 4 Then
                Cells(emptyRow, 4).Value = MyResult(i)
                Cells(emptyRow, 3).Value = MyResult(2) & " " & MyResult(3)
                Cells(emptyRow, 2).Value = MyResult(1)
            ElseIf i = 3 Then
                Cells(emptyRow, 4).Value = MyResult(i)
                Cells(emptyRow, 3).Value = MyResult(2)
                Cells(emptyRow, 2).Value = MyResult(1)
            Else
                Cells(emptyRow, 4).Value = MyResult(i)
                Cells(emptyRow, 3).Value = MyResult(1)
        End If
        ElseIf i = 4 Then
            Cells(emptyRow, 3).Value = MyResult(3) & " " & MyResult(4)
            Cells(emptyRow, 2).Value = MyResult(1) & " " & MyResult(2)
            ElseIf i = 3 Then
                Cells(emptyRow, 3).Value = MyResult(2) & " " & MyResult(3)
                Cells(emptyRow, 2).Value = MyResult(1)
            ElseIf i = 2 Then
                Cells(emptyRow, 3).Value = MyResult(2)
                Cells(emptyRow, 2).Value = MyResult(1)
            Else
                Cells(emptyRow, 3).Value = MyResult(1)
    End If

Thoughts??

CodePudding user response：

Here is my take on it. I included the choice of using extra names into either the middle or last name. It's quickly made and rather basic method and I'm sure there are various ways it could be improved but it works well regardless.

Have a go with it. Just set and change the necessary parts.

Sub ExtractName()

Dim ws As Worksheet, lRow As Long, i As Long, SplitName, IsSuffix As Boolean
Dim LastNamePos As Integer, j As Integer, SplitLast As Integer, LastStart As Integer

Set ws = Sheets("Sheet1")
lRow = ws.Range("A" & ws.Rows.Count).End(xlUp).Row 'Change column as needed

With ws
    For i = 2 To lRow 'change starting row if needed
        SplitName = Split(.Range("A" & i), " ")
        SplitLast = UBound(SplitName)
        Select Case SplitName(SplitLast)
            Case "Jr", "Jr.", "Sr", "Sr.", "II", "III", "IV", "V"
                .Range("E" & i) = SplitName(SplitLast) 'Add Suffix to column
                IsSuffix = True
            Case Else
                IsSuffix = False
        End Select
        .Range("B" & i) = SplitName(0) 'Add first name to column

        If IsSuffix = True Then
            LastNamePos = 1
        Else
            LastNamePos = 0
        End If
        '---------------------- Extra names go to middle name
        .Range("D" & i) = SplitName(SplitLast - LastNamePos) 'Add last name to column
        For j = 1 To SplitLast - LastNamePos - 1 'Add middle names to column
            If .Range("C" & i) = "" Then
                .Range("C" & i) = SplitName(j)
            Else
                .Range("C" & i) = .Range("C" & i) & " " & SplitName(j)
            End If
        Next j
        '---------------------- Extra names go to last name
'        If IsSuffix = True And SplitLast >= 3 Then
'            .Range("C" & i) = SplitName(1)
'            LastStart = 2
'        ElseIf IsSuffix = False And SplitLast >= 2 Then
'            .Range("C" & i) = SplitName(1)
'            LastStart = 2
'        Else
'            LastStart = 1
'        End If
'        For j = LastStart To SplitLast - LastNamePos
'            If .Range("D" & i) = "" Then
'                .Range("D" & i) = SplitName(j)
'            Else
'                .Range("D" & i) = .Range("D" & i) & " " & SplitName(j)
'            End If
'        Next j
    Next i
End With

End Sub