Start Free TrialLog in
Avatar of stephenlecomptejr
stephenlecomptejrFlag for United States of America

asked on 

Need help with optimizing VBA parsing string for middle initial from several variants!

Please note the following code:

Here are the test cases that work:
DEL VALLE, ADRIAN
Danielle L. Temple
ALMAGUER III, JUAN M
GREEN PINKEY, STACEY Y

Here are the test cases that do not work:
Smittick, Donesha M.
PIERCE, JR., ROBERT J
JORDAN, Savannah L.


How may I change the below syntax to work properly or make it more succinct?

Public Function PullMiddleInitial(vFullName As Variant) As String
On Error GoTo Err_Proc

  Dim sFullName As String
  Dim sFirst As String
  Dim sMiddle As String
  Dim i As Integer
  Dim lCountSpace As Long

  If Not IsNull(vFullName) Then
    sFullName = vFullName
    DoEvents
    
    If CommaBeforeSpace(sFullName) = True Then
      'find where , comma is
      sFullName = Trim(Right(sFullName, Len([sFullName]) - InStr([sFullName], ",")))
      'it's a first name only with a space and middle initial is:
      If Len(sFullName) > 1 And CountofCharacterInString(sFullName, " ") = 1 Then
        sMiddle = Right(sFullName, 2)
        If Left(sMiddle, 1) = " " Then
          sMiddle = Trim(sMiddle)
        Else
          sMiddle = ""
        End If
      End If
    Else
      
      sMiddle = ""
      If CountofCharacterInString(sFullName, " ") > 1 Then
        '
        lCountSpace = 0
        If OneSpaceThenPeriod(sFullName) = True Then
          For i = 1 To Len(sFullName)
            If Mid(sFullName, i, 1) = " " Then
              If Not i + 1 > Len(sFullName) Then
                sMiddle = Mid(sFullName, i + 1, 1)
                Exit For
              End If
            End If
            
          Next
          
        Else
          For i = 1 To Len(sFullName)
            If Mid(sFullName, i, 1) = " " Then
              
              lCountSpace = lCountSpace + 1
            End If
            If Mid(sFullName, i, 1) = " " And lCountSpace = 2 Then
              'find 2nd space after
              If Not i - 1 < 1 And Len(sFullName) > 2 Then
                
                sMiddle = Mid(sFullName, i - 2, 3)
                If Left(sMiddle, 1) = " " Then
                  If Right(sMiddle, 1) = " " Then
                    sMiddle = Mid(sMiddle, 2, 1)
                    Exit For
                  End If
                Else
                  sMiddle = ""
                  Exit For
                End If
                
              End If
            End If
            
            If lCountSpace > 2 Then
              Exit For
            End If
            
            If Mid(sFullName, i, 1) = "." Then
              If i <> Len(sFullName) And Mid(sFullName, i - 2, 1) = " " Then
                If Not i - 1 < 1 Then
                  
                  sMiddle = Mid(sFullName, i - 1, 1)
                  sMiddle = Trim(sMiddle)
                  Exit For
                End If
              Else
                sMiddle = ""
                Exit For
              End If
            End If
          Next
          
        End If
      
      End If
    End If
  Else
    If CountofCharacterInString(sFullName, " ") = 1 Then
      
      sMiddle = Right(sFullName, 2)
      If Left(sMiddle, 1) = " " Then
        sMiddle = Right(sFullName, 1)
      Else
        sMiddle = ""
        
      End If
      
    End If
  End If

Exit_Proc:

  If CharacterOnly(sMiddle) = False Then
    sMiddle = ""
  End If

  If sMiddle <> "" Then PullMiddleInitial = sMiddle
  Exit Function
  
Err_Proc:
  Call LogError(Err, Err.Description, "_mTasks @ PullMiddleInitial")
  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
Bembi
Avatar of Bembi
Bembi
Flag of Germany image
Can you also provide the functions:
CommaBeforeSpace
OneSpaceThenPeriod
SMiddle
CharacterOnly
Avatar of stephenlecomptejr
stephenlecomptejr
Flag of United States of America image

ASKER

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

Avatar of ste5an
ste5an
Flag of Germany image
Please apply some of my ideas and post a follow-up. Cause it is too hard to read.
Avatar of Bembi
Bembi
Flag of Germany image
Hello,

I tried to make it a bit more easier....
First procedure is just to test names....
Second procedure is the major one...

I first try tonormalize the names and to throw out everything not needed.
You may add additional conditions.

The StripText works as cut, replace
After this I split the Text into 3 parts, which are stored in the variable Name1,2,3
With these variables you can built any format you wish.
The major function has a second parameter which you can use to set the output. 

Option Explicit

Private Name1 As String
Private Name2 As String
Private Name3 As String

Private Sub NTest()
Dim z As Long
Dim back As String
Dim TestText(22) As String
TestText(0) = "PIERCE, JR., ROBERT J"
TestText(1) = "JOHNSON JR, TONY"
TestText(2) = "BARLEY,, CARL"
TestText(3) = "ALMAGUER III, JUAN M"
TestText(4) = "Fidel I. Smith, Jr"
TestText(5) = "VINCENTE, MARTINNII"
TestText(6) = "ALMAGUER III, JUAN M"
TestText(7) = "Rosita M. De Los Santos"
TestText(8) = "DEL VALLE, ADRIAN"
TestText(9) = "Danielle L. Temple"
TestText(10) = "ALMAGUER III, JUAN M"
TestText(11) = "GREEN PINKEY, STACEY Y"
'
TestText(12) = "Smittick, Donesha M."
TestText(13) = "PIERCE, JR., ROBERT J"
TestText(14) = "JORDAN, Savannah L."
TestText(15) = "VINCENTE, MARTINNII"
TestText(16) = "FOXWORTH, REED JR"
TestText(17) = "GREEN, HARVELL JR"
TestText(18) = "Fidel I. Smith, Jr"
TestText(19) = "Kevin Mathews, II"
TestText(20) = "Rosita M. De Los Santos"
TestText(21) = "PUNCH, JR., LARRY"
TestText(22) = "HOPES, JR., ROOSEVELT"

For z = 0 To 22
back = GetNamePart(TestText(z), 9)
Debug.Print back
Next

End Sub


Public Function GetNamePart(ByVal strName As String, strPart As Long) As String
'0 = Norm Name Last, First, Middle
'1 = FirstName
'2 = Middel Name
'3 = Last Name


Dim tempName As String
Dim FName As String
Dim MName As String
Dim LName As String

tempName = strName
tempName = StripText(tempName, "JR.", "")
tempName = StripText(tempName, ", JR", "")
tempName = StripText(tempName, " JR", "")
tempName = StripText(tempName, ", iii", "")
tempName = StripText(tempName, " iii", "")
tempName = StripText(tempName, ", ii", "")
tempName = StripText(tempName, " ii", "")

'Last Filter
tempName = StripText(tempName, ",,", ",")
tempName = StripText(tempName, ", ,", ",")
tempName = StripText(tempName, "  ", " ")

GetNamePart = GetNames(tempName)
Select Case strPart
Case 1: GetNamePart = Name1
Case 2: GetNamePart = Name2
Case 3: GetNamePart = Name3
Case 9: GetNamePart = Name1 + ", " + Name2 + " " + Name3
End Select

End Function


Private Function StripText(strName As String, TextToStrip As String, TextToAdd As String) As String

Dim NPos As Long
NPos = InStr(LCase$(strName), LCase(TextToStrip))
If NPos > 0 Then
    StripText = Left$(strName, NPos - 1) + TextToAdd + Mid$(strName, NPos + Len(TextToStrip))
Else
    StripText = strName
End If

End Function

Private Function GetNames(strName As String) As Boolean
Dim NPos As Long
Dim NameTemp As String

NameTemp = strName
NPos = InStr(LCase$(NameTemp), ",")
If NPos > 0 Then
    'Name has Comma, first string is lastname
    Name1 = Trim$(Left$(NameTemp, NPos - 1))
    NameTemp = Trim$(Mid$(NameTemp, NPos + 1, Len(NameTemp) - 1))
    NPos = InStr(LCase$(NameTemp), " ")
    If NPos > 0 Then
        Name2 = Trim$(Left$(NameTemp, NPos - 1))
        Name3 = Trim$(Mid$(NameTemp, NPos + 1, Len(NameTemp) - 1))
    Else
        Name2 = Trim$(NameTemp)
        Name3 = ""
    End If
    
    'Change Positions
    If Len(Name2) < 4 Then
        NameTemp = Name2
        Name2 = Name3
        Name3 = NameTemp
    End If
    
Else
    'Name has no Comma, first string is firstname
    NPos = InStr(LCase$(NameTemp), " ")
    If NPos > 0 Then
        Name2 = Trim$(Left$(NameTemp, NPos - 1))
        NameTemp = Trim$(Mid$(NameTemp, NPos + 1, Len(NameTemp) - 1))
    End If
    NPos = InStr(LCase$(NameTemp), " ")
    If NPos > 0 Then
        Name1 = Trim$(Left$(NameTemp, NPos - 1))
        Name3 = Trim$(Mid$(NameTemp, NPos + 1, Len(NameTemp) - 1))
    Else
        Name1 = Trim$(NameTemp)
        Name3 = ""
    End If

    'Change Positions
    If Len(Name1) < 4 Then
        NameTemp = Name1
        Name1 = Name3
        Name3 = NameTemp
    End If
End If

End Function

Open in new window

Avatar of ste5an
ste5an
Flag of Germany image
I would strongly recommend to avoid using global variables, use an array instead. Also I would use Option Compare Text to avoid the case fiddling. E,g,

Option Compare Text
Option Explicit

Public Function ExtractNamePart(ByVal strName As String, Optional strPart As Long = 0) As String
  '0 = Norm Name Last, First, Middle
  '1 = FirstName
  '2 = Middel Name
  '3 = Last Name
  
  Dim Names() As String
  Dim tempName As String
  Dim FName As String
  Dim MName As String
  Dim LName As String
  
  tempName = strName
  tempName = StripText(tempName, "JR.", "")
  tempName = StripText(tempName, ", JR", "")
  tempName = StripText(tempName, " JR", "")
  tempName = StripText(tempName, ", iii", "")
  tempName = StripText(tempName, " iii", "")
  tempName = StripText(tempName, ", ii", "")
  tempName = StripText(tempName, " ii", "")
  tempName = StripText(tempName, ",,", ",")
  tempName = StripText(tempName, ", ,", ",")
  tempName = StripText(tempName, "  ", " ")
  ExtractNamePart = GetNames(tempName, Names)
  Select Case strPart
  Case 1: ExtractNamePart = Names(0)
  Case 2: ExtractNamePart = Names(1)
  Case 3: ExtractNamePart = Names(2)
  Case Else
    ExtractNamePart = Names(0) + ", " + Names(1) + " " + Names(2)
  End Select

End Function

Private Function GetNames(ByVal strName As String, ByRef ONames() As String) As Boolean
  
  Dim NPos As Long
  Dim NameTemp As String
  
  ReDim ONames(0 To 2)
  
  NameTemp = strName
  NPos = InStr(NameTemp, ",")
  If NPos > 0 Then
      'Name has Comma, first string is lastname
      ONames(0) = Trim(Left(NameTemp, NPos - 1))
      NameTemp = Trim(Mid(NameTemp, NPos + 1, Len(NameTemp) - 1))
      NPos = InStr(NameTemp, " ")
      If NPos > 0 Then
          ONames(1) = Trim(Left(NameTemp, NPos - 1))
          ONames(2) = Trim(Mid(NameTemp, NPos + 1, Len(NameTemp) - 1))
      Else
          ONames(1) = Trim(NameTemp)
          ONames(2) = ""
      End If
      
      'Change Positions
      If Len(ONames(1)) < 4 Then
          NameTemp = ONames(1)
          ONames(1) = ONames(2)
          ONames(2) = NameTemp
      End If
      
  Else
      'Name has no Comma, first string is firstname
      NPos = InStr(NameTemp, " ")
      If NPos > 0 Then
          ONames(1) = Trim(Left(NameTemp, NPos - 1))
          NameTemp = Trim(Mid(NameTemp, NPos + 1, Len(NameTemp) - 1))
      End If
      NPos = InStr(NameTemp, " ")
      If NPos > 0 Then
          ONames(0) = Trim(Left(NameTemp, NPos - 1))
          ONames(2) = Trim(Mid(NameTemp, NPos + 1, Len(NameTemp) - 1))
      Else
          ONames(0) = Trim(NameTemp)
          ONames(2) = ""
      End If
  
      'Change Positions
      If Len(ONames(0)) < 4 Then
          NameTemp = ONames(0)
          ONames(0) = ONames(2)
          ONames(2) = NameTemp
      End If
  End If

End Function

Private Function StripText(strName As String, TextToStrip As String, TextToAdd As String) As String

  Dim NPos As Long
  NPos = InStr(strName, TextToStrip)
  If NPos > 0 Then
      StripText = Left(strName, NPos - 1) + TextToAdd + Mid(strName, NPos + Len(TextToStrip))
  Else
      StripText = strName
  End If

End Function

Private Sub Test()

  Dim z As Long
  Dim TestText(22) As String
  
  TestText(0) = "PIERCE, JR., ROBERT J"
  TestText(1) = "JOHNSON JR, TONY"
  TestText(2) = "BARLEY,, CARL"
  TestText(3) = "ALMAGUER III, JUAN M"
  TestText(4) = "Fidel I. Smith, Jr"
  TestText(5) = "VINCENTE, MARTINNII"
  TestText(6) = "ALMAGUER III, JUAN M"
  TestText(7) = "Rosita M. De Los Santos"
  TestText(8) = "DEL VALLE, ADRIAN"
  TestText(9) = "Danielle L. Temple"
  TestText(10) = "ALMAGUER III, JUAN M"
  TestText(11) = "GREEN PINKEY, STACEY Y"
  TestText(12) = "Smittick, Donesha M."
  TestText(13) = "PIERCE, JR., ROBERT J"
  TestText(14) = "JORDAN, Savannah L."
  TestText(15) = "VINCENTE, MARTINNII"
  TestText(16) = "FOXWORTH, REED JR"
  TestText(17) = "GREEN, HARVELL JR"
  TestText(18) = "Fidel I. Smith, Jr"
  TestText(19) = "Kevin Mathews, II"
  TestText(20) = "Rosita M. De Los Santos"
  TestText(21) = "PUNCH, JR., LARRY"
  TestText(22) = "HOPES, JR., ROOSEVELT"

  For z = 0 To UBound(TestText())
    Debug.Print Right("00" & z, 2); Chr(9); TestText(z); Chr(9); "=>"; Chr(9); ExtractNamePart(TestText(z))
  Next

End Sub

Open in new window

And I would split the GetNames() method into one method per format.
Avatar of stephenlecomptejr
stephenlecomptejr
Flag of United States of America image

ASKER

Need some time before I respond.  Just come back from a funeral.
Avatar of Bembi
Bembi
Flag of Germany image
No problem, to avoid closing by moderators, you may give a short feedback once a week.
I put you also the test procedure in my code so you are able to test other name constructions to add more filters (StripText).
Rather than to handle all parts individually, the sense of this construction is, first to normalize all possibly construction to make it simpler to get the single parts.
Avatar of stephenlecomptejr
stephenlecomptejr
Flag of United States of America image

ASKER

Bambi, fyi - I tried your code and changed only this part:

For z = 0 To 22
back = GetNamePart(TestText(z), 2)
Debug.Print back
Next

Open in new window


which 2 is grab me the middle name - but doesn't truly give the middle name (or middle initial as the original intent)

Avatar of stephenlecomptejr
stephenlecomptejr
Flag of United States of America image

ASKER

ste5an, fyi - I tried your code and only changed the Test() function part to:

  For z = 0 To UBound(TestText())
    Debug.Print ExtractNamePart(TestText(z), 2)
  Next

Open in new window

and it gave me the first name and no middle name.
Avatar of stephenlecomptejr
stephenlecomptejr
Flag of United States of America image

ASKER

Public Function PullMiddleInitial(vFullName As Variant) As String
On Error GoTo Err_Proc

  Dim sFullName As String
  Dim sFirst As String
  Dim sMiddle As String
  Dim i As Integer
  Dim lCountSpace As Long

  If Not IsNull(vFullName) Then
    sFullName = vFullName
    sFullName = Trim(sFullName)
    DoEvents
    
    If Right(sFullName, 1) = "." Then
      
      If Mid(sFullName, Len(sFullName) - 2, 1) = " " Then
        sMiddle = Mid(sFullName, Len(sFullName) - 1, 1)
        sMiddle = Trim(sMiddle)
        GoTo Exit_Proc
      End If
      
    End If
    
    If Mid(sFullName, Len(sFullName) - 1, 1) = " " Then
      
      sMiddle = Right(sFullName, 1)
      sMiddle = Trim(sMiddle)
      GoTo Exit_Proc
      
    End If
    
    If CommaBeforeSpace(sFullName) = True Then
      'find where , comma is
      sFullName = Trim(Right(sFullName, Len([sFullName]) - InStr([sFullName], ",")))
      'it's a first name only with a space and middle initial is:
      If Len(sFullName) > 1 And CountofCharacterInString(sFullName, " ") = 1 Then
        sMiddle = Right(sFullName, 2)
        If Left(sMiddle, 1) = " " Then
          sMiddle = Trim(sMiddle)
        Else
          sMiddle = ""
        End If
      End If
    Else
      
      sMiddle = ""
      If CountofCharacterInString(sFullName, " ") > 1 Then
        '
        lCountSpace = 0
        If OneSpaceThenPeriod(sFullName) = True Then
          For i = 1 To Len(sFullName)
            If Mid(sFullName, i, 1) = " " Then
              If Not i + 1 > Len(sFullName) Then
                sMiddle = Mid(sFullName, i + 1, 1)
                Exit For
              End If
            End If
            
          Next
          
        Else
          For i = 1 To Len(sFullName)
            If Mid(sFullName, i, 1) = " " Then
              
              lCountSpace = lCountSpace + 1
            End If
            If Mid(sFullName, i, 1) = " " And lCountSpace = 2 Then
              'find 2nd space after
              If Not i - 1 < 1 And Len(sFullName) > 2 Then
                
                sMiddle = Mid(sFullName, i - 2, 3)
                If Left(sMiddle, 1) = " " Then
                  If Right(sMiddle, 1) = " " Then
                    sMiddle = Mid(sMiddle, 2, 1)
                    Exit For
                  End If
                Else
                  sMiddle = ""
                  Exit For
                End If
                
              End If
            End If
            
            If lCountSpace > 2 Then
              Exit For
            End If
            
            If Mid(sFullName, i, 1) = "." Then
              If i <> Len(sFullName) And Mid(sFullName, i - 2, 1) = " " Then
                If Not i - 1 < 1 Then
                  
                  sMiddle = Mid(sFullName, i - 1, 1)
                  sMiddle = Trim(sMiddle)
                  Exit For
                End If
              Else
                sMiddle = ""
                Exit For
              End If
            End If
          Next
          
        End If
      
      End If
    End If
  Else
    If CountofCharacterInString(sFullName, " ") = 1 Then
      
      sMiddle = Right(sFullName, 2)
      If Left(sMiddle, 1) = " " Then
        sMiddle = Right(sFullName, 1)
      Else
        sMiddle = ""
        
      End If
      
    End If
  End If

Exit_Proc:

  If CharacterOnly(sMiddle) = False Then
    sMiddle = ""
  End If

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

Open in new window

This is what worked for me to solve it.  Just wanted to create more readable code.
ASKER CERTIFIED SOLUTION
Avatar of Bembi
Bembi
Flag of Germany image
Blurred text
THIS SOLUTION IS ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
See Pricing Options
Start Free Trial
Microsoft Access
Microsoft Access

Microsoft Access is a rapid application development (RAD) relational database tool. Access can be used for both desktop and web-based applications, and uses VBA (Visual Basic for Applications) as its coding language.

226K
Questions
--
Followers
--
Top Experts
Get a personalized solution from industry experts
Ask the experts

  • "Invaluable tool for our organization"

    Josh Regalski

  • "Your help has saved me hundreds of hours of internet surfing."

    @fblack61

  • "Just a dang good service!"

    @golferski

  • "Worth every penny."

    Steve Hougom

  • "It’s been a life saver."

    Maria Halt

  • "Best support site I’ve seen!"

    Bob Schneider

  • "I would be lost without them."

    @fblack61

  • "Saved my job multiple times."

    Walt Forbes

  • "I love this site."

    Maria Duwe

  • "Friendly respectful help."

    Andrew Kowtalo

  • "Such top-notch experts."

    @magento

  • "The best money I have ever spent."

    @rwheeler23

  • "Beyond any comprehensible value"

    George Morris

  • "Invaluable tool for our organization"

    Josh Regalski

Read over 600 more reviews

TRUSTED BY

IBM logoIntel logoMicrosoft logoUbisoft logoSAP logo
Qualcomm logoCitrix Systems logoWorkday logoErnst & Young logo
High performer badgeUsers love us badge
LinkedIn logoFacebook logoX logoInstagram logoTikTok logoYouTube logo
© 1996-2023 Experts Exchange, LLC. All rights reserved. Covered by US Patent