Hi,

I have a list of email IDs which need to be seperated by First Name, Middle Name and Last Name.

Example
--------
[email protected]
[email protected]
[email protected]
[email protected]
[email protected]
[email protected]
[email protected]
[email protected]
[email protected]
jamie O lennox @something.com
[email protected]
olena z [email protected]
[email protected]
[email protected]

as you can see these IDs have first name middle name and a last name.

The name are seperated by dot, space, middle initial or underscore. Is there a way to write a code which can segregate the first, middle and last name in three different columns. I have tried this code but its not working. I do not need the @something.com.



Sub Names()
Rng = Selection.Rows.Count
ActiveCell.Offset(0, 0).Select
Application.ScreenUpdating = False
For i = 1 To Rng
If ActiveCell.Value = "*." Then
ActiveCell.Select
With ActiveCell.Characters(Start:=1, Length:="*.").Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = 1
    End With
    ActiveCell.Offset(0, -1).Select
    ActiveSheet.Paste
    ActiveCell.Offset(1, 1).Select
Else
ActiveCell.Offset(1, 0).Select
End If
Next i
Application.ScreenUpdating = True
End Sub

Any help on this will be greatly appreciated.

Not sure how you'd differentiate via code which character is the middle initial without some complex code that won't always work anyway. If it will always be Last, MI, First order for name you can extract the names relatively easily. Below is a way to separate the name into three different strings; Hopefully you can extrapolate from there:
-------------------------------------------------------------------
Private Sub CommandButton1_Click()

Dim sAddress As String, sFirst As String, sMI As String, sLast As String, iChar As Long
sAddress = Selection.Value
iChar = InStr(1, sAddress, "@")
If iChar > 0 Then sAddress = Left(sAddress, iChar - 1) 'Chop off Everything @ and after
sAddress = Replace(sAddress, ".", ",") 'Replace . with ,
sAddress = Replace(sAddress, " ", ",") 'Replace spaces with ,
sAddress = Replace(sAddress, "_", ",") 'replace _ with ,
'Removes any instance where replace could cause two or more camas
Do While InStr(1, sAddress, ",,") > 0
  sAddress = Replace(sAddress, ",,", ",")
Loop
If Right(sAddress, 1) = "," Then sAddress = Left(sAddress, Len(sAddress) - 1)
iChar = InStr(1, sAddress, ",")
If iChar > 0 Then
  sFirst = Left(sAddress, iChar - 1)
  sLast = Right(sAddress, Len(sAddress) - iChar)
  iChar = InStr(1, sLast, ",")
' Only Separates middle inital when there is another ,
  If iChar > 0 Then
    sMI = Left(sLast, iChar - 1)
    sLast = Right(sLast, Len(sLast) - iChar)
  End If
Else
  sFirst = sAddress
End If
MsgBox "First: " & sFirst & vbCrLf & "MI: " & sMI & vbCrLf & "Last: " & sLast

End Sub
-------------------------------------------------------------------

Hope this helps.

P.S. If ALL your middle initial occurances will always be the only capital letter, you could use that for your separation criteria.