Avatar of stephenlecomptejr
stephenlecomptejrFlag for United States of America asked on

Need help with optimizing VBA parsing string for first name from several variants!

Please note the following code:

Here are the test cases that work:
Smittick, Donesha M.
Fidel I. Smith, Jr
VINCENTE, MARTINNII
ALMAGUER III, JUAN M
Rosita M. De Los Santos
BARLEY,, CARL

Here are the test cases that do not work:
PIERCE, JR., ROBERT J
PUNCH, JR., LARRY
HOPES, JR., ROOSEVELT

How may I change the below syntax to work properly or make it more succinct?
Public Function PullFirstName(vFullName As Variant) As String
On Error GoTo Err_Proc

  Dim sFullName As String
  Dim sFirst As String
  Dim bMiddle As Boolean
  Dim sMiddle As String
  Dim bSuffix As Boolean
  Dim sSuffix As String
  Dim slCase As String
  Dim i As Integer
 
  If Not IsNull(vFullName) Then
    sFullName = vFullName
    sFullName = Replace(sFullName, ".,", ",")
    sFullName = Replace(sFullName, ",,", ",")
    DoEvents
    
    If CommaBeforeSpace(sFullName) = True Then
      'process worked with UCU
      If sFullName Like "*,*" Then
        'find where , comma is
        sFullName = Trim(Right(sFullName, Len([sFullName]) - InStr([sFullName], ",")))
      End If
      'it's a first name only with a space and middle initial is:
      slCase = LCase(sFullName)
      If Len(slCase) > 2 Then
        If Right(slCase, 3) = "iii" Or Right(slCase, 3) = "jr." Or Right(slCase, 3) = "sr." Then
          bSuffix = True
          sSuffix = Right(sFullName, 3)
        Else
          If Right(slCase, 2) = "jr" Or Right(slCase, 2) = "sr" Or Right(slCase, 2) = "iv" Or Right(slCase, 2) = "ii" Then
            bSuffix = True
            sSuffix = Right(sFullName, 2)
          End If
        End If
      End If
      If Len(slCase) = 2 Then
        If Right(slCase, 2) = "jr" Or Right(slCase, 2) = "sr" Or Right(slCase, 2) = "iv" Or Right(slCase, 2) = "ii" Then
          bSuffix = True
          sSuffix = Right(sFullName, 2)
        End If
      End If
      'it's a first name only with a space and middle initial is:
      If Len(sFullName) > 1 And sFullName Like "* *" Then
        bMiddle = True
        sMiddle = Right(sFullName, 2)
        If Left(sMiddle, 1) = " " Then
          sFullName = Left(sFullName, Len(sFullName) - 2)
        Else
          sMiddle = ""
        End If
      End If
      If bSuffix = True Then
        sFullName = Left(sFullName, Len(sFullName) - Len(sSuffix))
        If sFullName = sSuffix Then
          sFullName = vFullName
        End If
      End If
      
      sFullName = Trim(sFullName)
      If sFullName Like "* *" Then
        '
        For i = 1 To Len(sFullName)
          If Mid(sFullName, i, 1) = " " And CountofCharacterInString(sFullName, " ") = 1 Then
            sFullName = Left(sFullName, i - 1)
            Exit For
          End If
        Next
      End If
      sFullName = Trim(sFullName)
      If sFullName <> "" And CountofCharacterInString(sFullName, " ") > 1 Then
        sFullName = ""
      End If
      
    End If
    If sFullName = "" Or CountofCharacterInString(sFullName, " ") > 0 Then
      sFullName = vFullName
      '
      'assume first space determines first name if normal format.
      For i = 1 To Len(sFullName)
        If Mid(sFullName, i, 1) = " " Then
          sFullName = Left(sFullName, i - 1)
          Exit For
        End If
      Next
    End If
    sFullName = Trim(sFullName)
  End If
  
  If CharacterOnly(Right(sFullName, 1)) = False Then
    sFullName = Left(sFullName, Len(sFullName) - 1)
  End If
  
  If CountofCharacterInString(sFullName, " ") = 1 Then
    slCase = LCase(sFullName)
    If Len(slCase) > 3 Then
      If Right(slCase, 4) = " iii" Or Right(slCase, 4) = " jr." Or Right(slCase, 4) = " sr." Then
        bSuffix = True
        sSuffix = Right(sFullName, 3)
      Else
        If Right(slCase, 3) = " jr" Or Right(slCase, 3) = " sr" Or Right(slCase, 3) = " iv" Or Right(slCase, 3) = " ii" Then
          bSuffix = True
          sSuffix = Right(sFullName, 2)
        End If
      End If
    End If
    If Len(slCase) = 2 Then
      If Right(slCase, 2) = "jr" Or Right(slCase, 2) = "sr" Or Right(slCase, 2) = "iv" Or Right(slCase, 2) = "ii" Then
        bSuffix = True
        sSuffix = Right(sFullName, 2)
      End If
    End If
    If Len(slCase) = 3 Then
      If Right(slCase, 3) = " jr" Or Right(slCase, 3) = " sr" Or Right(slCase, 3) = " iv" Or Right(slCase, 3) = " ii" Then
        bSuffix = True
        sSuffix = Right(sFullName, 2)
      End If
    End If
    
    If bSuffix = True Then
      sFullName = Replace(sFullName, sSuffix, "")
      sFullName = Trim(sFullName)
      
    End If
    
  End If
  
  If CountofCharacterInString(sFullName, " ") = 1 Then
      
    sMiddle = Right(sFullName, 2)
    If Left(sMiddle, 1) = " " Then
      sMiddle = Right(sFullName, 1)
    Else
      sMiddle = ""
      
    End If
    
    sFullName = Replace(sFullName, sMiddle, "")
    sFullName = Trim(sFullName)
    
  End If
   
Exit_Proc:

  If sFullName <> "" Then
    PullFirstName = sFullName
  End If
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mTasks @ PullFirstName")
  Resume Exit_Proc
  
End Function 

Public Function CountofCharacterInString(sValue As String, sCharacter As String) As Long
On Error GoTo Err_Proc

  Dim lCount As Long
  lCount = Len(sValue) - Len(Replace(sValue, sCharacter, ""))
  
Exit_Proc:
  CountofCharacterInString = lCount
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mTasks @ CountofCharacterInString")
  Resume Exit_Proc

End Function

Open in new window



Microsoft AccessVBA

Avatar of undefined
Last Comment
stephenlecomptejr

8/22/2022 - Mon
Bembi

Can you also provide the functions
CommaBeforeSpace
CharacterOnly
ASKER
stephenlecomptejr

Public Function CommaBeforeSpace(sValue As String) As Boolean
On Error GoTo Err_Proc

  Dim bFoundComma As Boolean
  Dim bFoundSpace As Boolean
  Dim bNewValue As Boolean
  Dim i As Integer
  
  If Not sValue Like "*,*" Then GoTo Exit_Proc
  
  For i = 1 To Len(sValue)
    If Mid(sValue, i, 1) = " " Then
      bFoundSpace = True
    End If
    If Mid(sValue, i, 1) = "," Then
      bFoundComma = True
      If bFoundComma = True And bFoundSpace = False Then
        bNewValue = True
      End If
      If bFoundComma = True And Not i + 1 > Len(sValue) Then
        If Mid(sValue, i + 1, 1) = " " Then
          bNewValue = True
        End If
        
      End If
      Exit For
    End If
  Next i
  
Exit_Proc:
  CommaBeforeSpace = bNewValue
  
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mTasks @ CommaBeforeSpace")
  Resume Exit_Proc
End Function

Public Function OneSpaceThenPeriod(sValue As String) As Boolean
On Error GoTo Err_Proc

  Dim bFoundPeriod As Boolean
  Dim bFoundSpace As Boolean
  Dim bNewValue As Boolean
  Dim lCount As Long
  Dim i As Integer
  
  'If Not sValue Like "*,*" Then GoTo Exit_Proc
  
  For i = 1 To Len(sValue)
    If Mid(sValue, i, 1) = " " Then
      lCount = lCount + 1
      bFoundSpace = True
    End If
    If Mid(sValue, i, 1) = "." Then
      If lCount = 1 Then
        bFoundPeriod = True
        bNewValue = True
      End If
      Exit For
    End If
    
  Next i
  
Exit_Proc:
  OneSpaceThenPeriod = bNewValue
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mTasks @ OneSpaceThenPeriod")
  Resume Exit_Proc
End Function

Public Function CharacterOnly(sValue As String) As Boolean
On Error GoTo Err_Proc

  Dim bValue As Boolean
  bValue = False
  
  If sValue = "" Then GoTo Exit_Proc
  If Asc(sValue) > 64 And Asc(sValue) < 91 Or Asc(sValue) > 96 And Asc(sValue) < 123 Then
    bValue = True
  End If
  
Exit_Proc:
  CharacterOnly = bValue
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mCommon @ CharacterOnly")
  Resume Exit_Proc

End Function

Open in new window

ste5an

Please apply some of my ideas and post a follow-up. Cause it is too hard to read.
Experts Exchange is like having an extremely knowledgeable team sitting and waiting for your call. Couldn't do my job half as well as I do without it!
James Murphy
SOLUTION
Bembi

Log in or sign up to see answer
Become an EE member today7-DAY FREE TRIAL
Members can start a 7-Day Free trial then enjoy unlimited access to the platform
Sign up - Free for 7 days
or
Learn why we charge membership fees
We get it - no one likes a content blocker. Take one extra minute and find out why we block content.
See how we're fighting big data
Not exactly the question you had in mind?
Sign up for an EE membership and get your own personalized solution. With an EE membership, you can ask unlimited troubleshooting, research, or opinion questions.
ask a question
ASKER
stephenlecomptejr

Need some time before I respond.  Just come back from a funeral.
Bembi

No problem, to avoid closing by moderators, you may give a short feedback once a week.
ASKER CERTIFIED SOLUTION
Log in to continue reading
Log In
Sign up - Free for 7 days
Get an unlimited membership to EE for less than $4 a week.
Unlimited question asking, solutions, articles and more.