Parse first name & surname from Windows logon name (Environ("UserName")

I was wondering if it would be possible to parse out an individuals first name & surname from their Windows logon name.

Obtaining the Windows logon name is easily done (

msgbox Environ("UserName")

) so the only real difficulty is:

1. Correctly parse names from as many variations of a user name as possible (i.e. names separated with a full stop, names separated with an underscore etcetcera) and
2. Ignore most standard non-individual names (e.g. Administrator, Admin, Accounts, Sales etcetcera)

A quick google search throws up many results on parsing names from cells but these don't have a good success rate on actual user name formats. Below is what I have so far.

Option Explicit
Option Private Module

Private strEnvironUserName As String

Public Sub test()
          Dim strName1 As String
          Dim strName2 As String
          Dim strName3 As String
          Dim strName4 As String
          Dim strName5 As String
          Dim strName6 As String

          'John Citizen is the dummy name for testing the code.
          'This will be replaced with Environ("UserName") once the code is working

10        strEnvironUserName = "John.Citizen"
20        strName1 = ParseOutNamesFromUserName(strEnvironUserName)

30        strEnvironUserName = "John_Citizen"
40        strName2 = ParseOutNamesFromUserName(strEnvironUserName)

50        strEnvironUserName = "John Citizen"
60        strName3 = ParseOutNamesFromUserName(strEnvironUserName)

70        strEnvironUserName = "JohnCitizen"
80        strName4 = ParseOutNamesFromUserName(strEnvironUserName)

90        strEnvironUserName = "Administrator"
100       strName5 = ParseOutNamesFromUserName(strEnvironUserName)

110       strEnvironUserName = "Admin"
120       strName6 = ParseOutNamesFromUserName(strEnvironUserName)



130       MsgBox strName1 'Working
140       MsgBox strName2 'not working
150       MsgBox strName3 'Working
160       MsgBox strName4 'not working
170       MsgBox strName5 'working (and it shouldn't)
180       MsgBox strName6 'working (and it shouldn't)
End Sub

Private Function ParseOutNamesFromUserName(strEnvironUserName As String) As Variant
          ''based on ParseOutNames
          ''http://www.cpearson.com/excel/firstlast.htm
          Dim FirstName As String
          Dim LastName As String
          Dim MidInitial As String
          Dim Suffix As String
          Dim Pos As Integer
          Dim Pos2 As Integer
          Dim Pos3 As Integer

10        Pos = InStr(1, strEnvironUserName, ".", vbTextCompare)
20        If Pos = 0 Then
30            Pos = Len(strEnvironUserName) + 1
40        End If
50        LastName = Trim(Left(strEnvironUserName, Pos - 1))

60        Pos2 = InStr(1, LastName, " ", vbTextCompare)
70        If Pos2 Then
80            Pos3 = InStr(Pos2 + 1, LastName, " ", vbTextCompare)
90            If Pos3 Then
100               Suffix = Right(LastName, Len(LastName) - Pos3)
110               LastName = Left(LastName, Pos3 - 1)
120           Else
130               Suffix = Right(LastName, Len(LastName) - Pos2)
140               LastName = Left(LastName, Pos2 - 1)
150           End If
160       End If

170       Pos2 = InStr(Pos + 2, strEnvironUserName, " ", vbTextCompare)
180       If Pos2 = 0 Then
190           Pos2 = Len(strEnvironUserName)
200       End If

210       If Pos2 > Pos Then
220           FirstName = Mid(strEnvironUserName, Pos + 1, Pos2 - Pos)
230           MidInitial = Right(strEnvironUserName, Len(strEnvironUserName) - Pos2)
240       End If
          
250       Pos = InStr(1, LastName, "-", vbTextCompare)
260       If Pos Then
270           LastName = Trim(StrConv(Left(LastName, Pos), vbProperCase)) & _
              Trim(StrConv(Right(LastName, Len(LastName) - Pos), vbProperCase))
280       Else
290           LastName = Trim(StrConv(LastName, vbProperCase))
300       End If

310       FirstName = Trim(StrConv(FirstName, vbProperCase))
320       MidInitial = Trim(StrConv(MidInitial, vbProperCase))
330       Suffix = Trim(StrConv(Suffix, vbProperCase))
          '
          ' suffix handling
          '
340       Select Case UCase(Suffix)
              Case "JR", "SR", "II", "III", "IV", "MD", "PHD", "PH.D", "M.D."
          
350           Case Else
360               If Not IsNumeric(Left(Suffix, 1)) Then
370                   LastName = LastName & " " & Suffix
380                   Suffix = ""
390               End If
400       End Select
          
410       ParseOutNamesFromUserName = LastName & FirstName & MidInitial & Suffix

End Function

I think you've set yourself a task there..

Part of the solution may be to count the number of words in the name as a first step... You could modify the function to include seperators..

Public Function WordCount(IpData As String) As Long
Dim Z As Long, ZZ As Long, TestChar As String

    For Z = 1 To Len(IpData)
    TestChar = UCase(Mid(IpData, Z, 1))
    If Asc(TestChar) = 32 Then
        For ZZ = Z To Z + 100
            TestChar = UCase(Mid(IpData, ZZ, 1))
            If Asc(TestChar) = 32 Then
                WordCount = WordCount + 1
                Z = ZZ
                Exit For
            End If
        Next ZZ
    End If
    Next Z
    
End Function

Originally Posted by AndyLitch

I think you've set yourself a task there..

True. I enjoy the challenge though.

Originally Posted by AndyLitch

Part of the solution may be to count the number of words in the name as a first step... You could modify the function to include seperators..

Thank you for the suggestion. I'm looking into it now. (I'm trying to think of a solution to handle when the first and last name don't have a separator. e.g. JohnSmith )

I am now up to this (see code below). It's not perfect. If you try it and your user name is not parsed by the function, I would be interested in knowing what it is so I can tweak it further.

Option Explicit
Private strEnvironUserName As String
Private Msg As String, Ans As Integer, Config As Integer, Title As String

Public Sub Test_EnvironUserNameToFirstLastNames()
    'John Citizen is the dummy name for testing the code.
    'This will be replaced with Environ("UserName") once the code is working
    Dim strName1 As String
    Dim strName2 As String
    Dim strName3 As String
    Dim strName4 As String
    Dim strName5 As String
    Dim strName6 As String
    Dim strName7 As String

'use delimiters
    strName1 = UserNameToFirstLast("John.Citizen")
    strName2 = UserNameToFirstLast("John_Citizen")
    strName3 = UserNameToFirstLast("John Citizen")
'no delimiters
    'use Capitals as delimiters
    strName4 = UserNameToFirstLast("JohnCitizen")
    'single name - should return as first name only
    strName5 = UserNameToFirstLast("John")
    'not user names - somehow pick these up and reject them
    strName6 = UserNameToFirstLast("Administrator")
    strName7 = UserNameToFirstLast("Admin")

    Msg = "1 " & strName1
    Msg = Msg & vbNewLine & "2 " & strName2
    Msg = Msg & vbNewLine & "3 " & strName3
    Msg = Msg & vbNewLine & "4 " & strName4
    Msg = Msg & vbNewLine & "5 " & strName5
    Msg = Msg & vbNewLine & "6 " & strName6
    Msg = Msg & vbNewLine & "7 " & strName7
    Msg = UserNameToFirstLast(Environ("UserName"))
    Ans = MsgBox(Msg, Config, Title)
End Sub

Private Function UserNameToFirstLast(strUserName As String) As String
'   give up if user name is all caps
    If UCase(strUserName) = strUserName Then GoTo CouldNotSolve

'   should have code here to give up if user name contains numerics

    Select Case strUserName
'   give up if user name = common non-user name log-ins
        Case "Admin"
        Case "Administrator"
        Case "Sales"
        Case "Accounts"
        Case Else
'   try to pass user name into first name & last name
            UserNameToFirstLast = "Your user name is: First = " & FIRSTNAME(strUserName) & " Last = " & LASTNAME(strUserName)
            Exit Function
    End Select

CouldNotSolve:
    UserNameToFirstLast = "Could not parse into first & surname"
End Function

Public Function FIRSTNAME(strName As String) As String
    Dim intCharacter As Integer
    FIRSTNAME = Left(strName, 1)
    For intCharacter = 2 To Len(strName)
        If UCase(Mid(strName, intCharacter, 1)) = Mid(strName, intCharacter, 1) Then
            Exit For
        Else
            FIRSTNAME = FIRSTNAME & Mid(strName, intCharacter, 1)
        End If
    Next intCharacter
End Function

Public Function LASTNAME(strName As String) As String
    Dim intCharacter As Integer
    For intCharacter = 2 To Len(strName)
        If UCase(Mid(strName, intCharacter, 1)) = Mid(strName, intCharacter, 1) Then
            If Mid(strName, intCharacter, 1) Like "[A-Z]" = True Then
                LASTNAME = Right(strName, Len(strName) - intCharacter + 1)
            Else 'remove delimiter
                LASTNAME = Right(strName, Len(strName) - intCharacter)
            End If
            Exit For
        End If
    Next intCharacter
End Function

Private Function ParseOutNamesFromUserName(strEnvironUserName As String) As Variant
    ''based on ParseOutNames http://www.cpearson.com/excel/firstlast.htm
    Dim FIRSTNAME As String
    Dim LASTNAME As String
    Dim MidInitial As String
    Dim Suffix As String
    Dim Pos As Integer
    Dim Pos2 As Integer
    Dim Pos3 As Integer

    Pos = InStr(1, strEnvironUserName, ".", vbTextCompare)
    If Pos = 0 Then Pos = Len(strEnvironUserName) + 1
    LASTNAME = Trim(Left(strEnvironUserName, Pos - 1))

    Pos2 = InStr(1, LASTNAME, " ", vbTextCompare)
    If Pos2 Then
        Pos3 = InStr(Pos2 + 1, LASTNAME, " ", vbTextCompare)
        If Pos3 Then
            Suffix = Right(LASTNAME, Len(LASTNAME) - Pos3)
            LASTNAME = Left(LASTNAME, Pos3 - 1)
        Else
            Suffix = Right(LASTNAME, Len(LASTNAME) - Pos2)
            LASTNAME = Left(LASTNAME, Pos2 - 1)
        End If
    End If

    Pos2 = InStr(Pos + 2, strEnvironUserName, " ", vbTextCompare)
    If Pos2 = 0 Then
        Pos2 = Len(strEnvironUserName)
    End If

    If Pos2 > Pos Then
        FIRSTNAME = Mid(strEnvironUserName, Pos + 1, Pos2 - Pos)
        MidInitial = Right(strEnvironUserName, Len(strEnvironUserName) - Pos2)
    End If
    
    Pos = InStr(1, LASTNAME, "-", vbTextCompare)
    If Pos Then
        LASTNAME = Trim(StrConv(Left(LASTNAME, Pos), vbProperCase)) & _
        Trim(StrConv(Right(LASTNAME, Len(LASTNAME) - Pos), vbProperCase))
    Else
        LASTNAME = Trim(StrConv(LASTNAME, vbProperCase))
    End If

    FIRSTNAME = Trim(StrConv(FIRSTNAME, vbProperCase))
    MidInitial = Trim(StrConv(MidInitial, vbProperCase))
    Suffix = Trim(StrConv(Suffix, vbProperCase))
    '
    ' suffix handling
    '
    Select Case UCase(Suffix)
        Case "JR", "SR", "II", "III", "IV", "MD", "PHD", "PH.D", "M.D."
    
        Case Else
            If Not IsNumeric(Left(Suffix, 1)) Then
                LASTNAME = LASTNAME & " " & Suffix
                Suffix = ""
            End If
    End Select

    ParseOutNamesFromUserName = "Last = " & LASTNAME & "First = " & FIRSTNAME & " MidInitial = " & MidInitial & " Suffix = " & Suffix
End Function

if the users are on an active directory domain you could just query the domain controller for the user name

Originally Posted by JosephP

if the users are on an active directory domain you could just query the domain controller for the user name

Appreciate the suggestion. However I want this function as versatile as possible - work on non-networked PCs for e.g.