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
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
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
ASKER
For z = 0 To 22
back = GetNamePart(TestText(z), 2)
Debug.Print back
Next
ASKER
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.
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.
TRUSTED BY
CommaBeforeSpace
OneSpaceThenPeriod
SMiddle
CharacterOnly