stephenlecomptejr
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?
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
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
Please apply some of my ideas and post a follow-up. Cause it is too hard to read.
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.
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
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
And I would split the GetNames() method into one method per format.
ASKER
Need some time before I respond. Just come back from a funeral.
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.
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.
ASKER
Bambi, fyi - I tried your code and changed only this part:
which 2 is grab me the middle name - but doesn't truly give the middle name (or middle initial as the original intent)
For z = 0 To 22
back = GetNamePart(TestText(z), 2)
Debug.Print back
Next
which 2 is grab me the middle name - but doesn't truly give the middle name (or middle initial as the original intent)
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
and it gave me the first name and no middle name.
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
This is what worked for me to solve it. Just wanted to create more readable code.
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
CommaBeforeSpace
OneSpaceThenPeriod
SMiddle
CharacterOnly