Split Names In One Cell to Multiple Columns

[azzurri13]

I have an output that puts multiple names into one cell. The names are in the format "LASTNAME, FIRSTNAME, LASTNAME2, FIRSTNAME2...)

I need to split the names up and with first and last name separated by a comma, I can't use the delimiter as a comma.

How can I approach this? Any help is appreciated, thanks

 

[JoeMo]

Is there a "carriage return" between names? Are there names with a middle initial or a suffix (Jr, Sr, ..)?

 

[azzurri13]

Is there a "carriage return" between names? Are there names with a middle initial or a suffix (Jr, Sr, ..)?

There is no carriage or middle initials

Thanks

 

[Rick Rothstein]

Assuming your names are in Column A starting at Row 1 (the red highlighted text sets this location), give this macro a try...

Sub SplitFirstLastNamesOutIntoSeparateCells()
  Dim R As Long, C As Long, S As Long, MaxNames As Long
  Dim Rng As Range, Data As Variant, FLnames() As String
  Set Rng = Range("[B][COLOR="#FF0000"]A1[/COLOR][/B]", Cells(Rows.Count, "[B][COLOR="#FF0000"]A[/COLOR][/B]").End(xlUp))
  MaxNames = Evaluate(Replace("MAX(0+(LEN(@)-LEN(SUBSTITUTE(@,"", "","""")))/2)", "@", Rng.Address))
  Data = Rng.Resize(, MaxNames)
  For R = 1 To UBound(Data)
    S = 0
    Data(R, 1) = Replace(Data(R, 1), ", ", ",")
    For C = 1 To Len(Data(R, 1))
      If Mid(Data(R, 1), C, 1) = "," Then
        S = S + 1
        If S Mod 2 = 0 Then Mid(Data(R, 1), C) = Chr(1)
      End If
    Next
    FLnames = Split(Data(R, 1) & Chr(1), Chr(1))
    For C = 1 To MaxNames
      If C <= UBound(FLnames) Then
        Data(R, C) = FLnames(C - 1)
      Else
        Data(R, C) = ""
      End If
    Next
  Next
  Rng.Resize(, MaxNames) = Data
End Sub

 

[VBA Geek]

i must be oversimplifying the issue but i think this should work too

[color=darkblue]Sub[/color] SplitNames()
[color=darkblue]Dim[/color] X [color=darkblue]As[/color] [color=darkblue]Long[/color], RawNames [color=darkblue]As[/color] [color=darkblue]String[/color], Y [color=darkblue]As[/color] [color=darkblue]Long[/color]


RawNames = [a1].Value


X = InStr(1, RawNames, ", ", vbBinaryCompare)
Y = 1


[color=darkblue]Do[/color] [color=darkblue]Until[/color] X = 0
    [color=darkblue]If[/color] Y Mod 2 = 0 [color=darkblue]Then[/color] Mid(RawNames, X, 1) = "@"
    X = InStr(X + 1, RawNames, ", ", vbBinaryCompare)
    Y = Y + 1
[color=darkblue]Loop[/color]


[a1] = Replace(RawNames, " ", vbNullString)
Range("A1").TextToColumns , xlDelimited, xlTextQualifierNone, [color=darkblue]False[/color], [color=darkblue]False[/color], [color=darkblue]False[/color], False, False, [color=darkblue]True[/color], "@"
[color=darkblue]End[/color] [color=darkblue]Sub[/color]

 

[azzurri13]

Assuming your names are in Column A starting at Row 1 (the red highlighted text sets this location), give this macro a try...

Sub SplitFirstLastNamesOutIntoSeparateCells()
  Dim R As Long, C As Long, S As Long, MaxNames As Long
  Dim Rng As Range, Data As Variant, FLnames() As String
  Set Rng = Range("[B][COLOR=#FF0000]A1[/COLOR][/B]", Cells(Rows.Count, "[B][COLOR=#FF0000]A[/COLOR][/B]").End(xlUp))
  MaxNames = Evaluate(Replace("MAX(0+(LEN(@)-LEN(SUBSTITUTE(@,"", "","""")))/2)", "@", Rng.Address))
  Data = Rng.Resize(, MaxNames)
  For R = 1 To UBound(Data)
    S = 0
    Data(R, 1) = Replace(Data(R, 1), ", ", ",")
    For C = 1 To Len(Data(R, 1))
      If Mid(Data(R, 1), C, 1) = "," Then
        S = S + 1
        If S Mod 2 = 0 Then Mid(Data(R, 1), C) = Chr(1)
      End If
    Next
    FLnames = Split(Data(R, 1) & Chr(1), Chr(1))
    For C = 1 To MaxNames
      If C <= UBound(FLnames) Then
        Data(R, C) = FLnames(C - 1)
      Else
        Data(R, C) = ""
      End If
    Next
  Next
  Rng.Resize(, MaxNames) = Data
End Sub

i must be oversimplifying the issue but i think this should work too

[COLOR=darkblue]Sub[/COLOR] SplitNames()
[COLOR=darkblue]Dim[/COLOR] X [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], RawNames [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR], Y [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]


RawNames = [a1].Value


X = InStr(1, RawNames, ", ", vbBinaryCompare)
Y = 1


[COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]Until[/COLOR] X = 0
    [COLOR=darkblue]If[/COLOR] Y Mod 2 = 0 [COLOR=darkblue]Then[/COLOR] Mid(RawNames, X, 1) = "@"
    X = InStr(X + 1, RawNames, ", ", vbBinaryCompare)
    Y = Y + 1
[COLOR=darkblue]Loop[/COLOR]


[a1] = Replace(RawNames, " ", vbNullString)
Range("A1").TextToColumns , xlDelimited, xlTextQualifierNone, [COLOR=darkblue]False[/COLOR], [COLOR=darkblue]False[/COLOR], [COLOR=darkblue]False[/COLOR], False, False, [COLOR=darkblue]True[/COLOR], "@"
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

Thank you! These both worked well!

 

[azzurri13]

i must be oversimplifying the issue but i think this should work too

[COLOR=darkblue]Sub[/COLOR] SplitNames()
[COLOR=darkblue]Dim[/COLOR] X [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR], RawNames [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]String[/COLOR], Y [COLOR=darkblue]As[/COLOR] [COLOR=darkblue]Long[/COLOR]


RawNames = [a1].Value


X = InStr(1, RawNames, ", ", vbBinaryCompare)
Y = 1


[COLOR=darkblue]Do[/COLOR] [COLOR=darkblue]Until[/COLOR] X = 0
    [COLOR=darkblue]If[/COLOR] Y Mod 2 = 0 [COLOR=darkblue]Then[/COLOR] Mid(RawNames, X, 1) = "@"
    X = InStr(X + 1, RawNames, ", ", vbBinaryCompare)
    Y = Y + 1
[COLOR=darkblue]Loop[/COLOR]


[a1] = Replace(RawNames, " ", vbNullString)
Range("A1").TextToColumns , xlDelimited, xlTextQualifierNone, [COLOR=darkblue]False[/COLOR], [COLOR=darkblue]False[/COLOR], [COLOR=darkblue]False[/COLOR], False, False, [COLOR=darkblue]True[/COLOR], "@"
[COLOR=darkblue]End[/COLOR] [COLOR=darkblue]Sub[/COLOR]

How could I run this on a whole column?

Thanks

 

[Rick Rothstein]

How could I run this on a whole column?

Just double-checking... you do realize that the code I posted in Message #4 already works for a whole column of your "multiple names in single cells", correct?

 

[azzurri13]

My mistake, thank you works perfectly!

 

[JoeMo]

For the record, here's another macro I wrote last night while waiting for the response to Post #2. Just now gotten to that response.

Sub SplitNamesToColumns()
'Select all the cells with multiple names in them, then run this macro
Dim C As Range, V As Variant, ct As Long
For Each C In Selection
    V = Split(Replace(C.Value, " ", ""), ",")
    Application.ScreenUpdating = False
    For i = LBound(V) To UBound(V) - 1 Step 2
        With C.Offset(0, ct)
                .Value = V(i) & "," & V(i + 1)
                .EntireColumn.AutoFit
                ct = ct + 1
        End With
    Next i
    ct = 0
    Erase V
Next C
Application.ScreenUpdating = True
 End Sub