Yesterday I found myself needing to do some name splitting due to a changed input file layout from a vendor. Naturally, this was for one of the few systems that does not interface with our SQL Server at all, so I could not use functions I already had on there. Rather than writing convoluted queries, I decided to write a set of simple functions to help me in this task.
This is a common question, and hopefully my collection of functions can help someone with it. These are tailored to my situation, but I am sure could be altered to fit most types of 'FULLNAME' inputs that I have seen.
The functions are as follows:
fTrimPrefix - Removes prefix from name (also works for prefixes Mr. and Mrs., Dr. and Mrs.)
fTrimSuffix - Removes suffixes from name (I pass through this twice to handle for Dual Suffixes. Wanted to have it remove one at a time in order to use this function within the function to return suffixes)
fGrabFName - First passes your input through fTrimPrefix, then extracts and returns the first name.
fGrabMName - First passes your input through fTrimSuffix(twice) and fTrimPrefix, then extracts and returns middle name.
fGrabLName - First passes your input through fTrimSuffix(Twice), then extracts and returns last name.
fGrabPrefix - Extracts and returns prefix.
fGrabSuffix - Extracts and returns suffix. In some cases, passing through fTrimSuffix(once) and getting suffix1 from this value, and getting suffix2 from the original input.
These are kind of raw, and I am sure there are things that could be done to improve them (as well as suf/prefixes) that could be added to the list. I am always open to suggestions.
Hope they Help,
Alex
Note - I separated the code into blocks to make it more readable, but these are really meant to all work together. Some will work independently, some won't.
CODEPublic Function fTrimPrefix(InCol)
Dim OutCol As String
'replace " and " for entries containing "Mr. and Mrs."
OutCol = Replace(Replace(InCol, " and ", " "), " & ", " ")
'check for nulls
'this is only necessary when selecting case Instr value - 1
If InStr(OutCol, " ") > 1 Then
'remove first prefix if present
Select Case Left(OutCol, InStr(OutCol, " ") - 1)
Case "Miss", "Mr.", "Ms.", "Mrs.", "Dr.", "Rev.", "Capt.", "Rabbi"
OutCol = Trim(Mid(OutCol, InStr(OutCol, " ") + 1, Len(OutCol)))
Case Else
OutCol = OutCol
End Select
'remove second prefix if present
Select Case Left(Trim(OutCol), InStr(Trim(OutCol), " ") - 1)
Case "Miss", "Mr.", "Ms.", "Mrs.", "Dr.", "Rev.", "Capt.", "Rabbi"
OutCol = Trim(Mid(OutCol, InStr(Trim(OutCol), " ") + 1, Len(Trim(OutCol))))
Case Else
OutCol = OutCol
End Select
Else
OutCol = OutCol
End If
fTrimPrefix = OutCol
End Function
CODEPublic Function fTrimSuffix(InCol As String)
'I am running this twice --> fTrimSuffix(fTrimSuffix(FULLNAME))
'when I need to trim the suffix. I only want it to trim one at a time
'so that it can be used with the fGrabSuffix function in returning
'dual suffixes
Dim OutCol As String
OutCol = InCol
'Remove Suffix if present
Select Case Trim(Right(OutCol, InStr(StrReverse(OutCol), " ")))
Case "MD", "Jr.", "III", "IV", "V", "Jr", "M.D.", "DDS", "Ret.", "USN"
OutCol = Left(OutCol, Len(OutCol) - InStr(StrReverse(OutCol), " "))
'Remove Comma if present
OutCol = Replace(OutCol, ",", "")
Case Else
OutCol = OutCol
End Select
fTrimSuffix = OutCol
End Function
CODEPublic Function fGrabFName(InCol As String)
Dim OutCol As String
'first use fTrimPrefix to get a clean (left side of) name
OutCol = fTrimPrefix(InCol)
'Extract first name from cleaned name (everything up to first space)
If InStr(OutCol, " ") > 1 Then
OutCol = Left(OutCol, InStr(OutCol, " ") - 1)
End If
fGrabFName = OutCol
End Function
CODEPublic Function fGrabMName(InCol As String)
Dim OutCol As String
'first use fTrimPrefix and fTrimSuffix to get a clean name
OutCol = fTrimSuffix(fTrimSuffix(fTrimPrefix(InCol)))
'Check for a second, non-trailing space after the first to appear in string
Select Case InStr(Trim(Mid(OutCol, InStr(OutCol, " ") + 1, Len(OutCol))), " ")
'If there is one, extract middle name (between first and second spaces)
Case Is > 0
OutCol = Mid(OutCol, InStr(OutCol, " ") + 1, Len(Mid(OutCol, InStr(OutCol, " ") + 1, _
InStr(Mid(OutCol, InStr(OutCol, " ") + 1, Len(OutCol)), " "))))
'If no second space, return blank middle name
Case Else
OutCol = ""
End Select
fGrabMName = OutCol
End Function
CODEPublic Function fGrabLName(InCol As String)
Dim OutCol As String
'first use fTrimSuffix to get a clean (right side of) name
OutCol = fTrimSuffix(fTrimSuffix(InCol))
'Check for nulls
If InStr(OutCol, " ") > 1 Then
'Extract Last Name (everything after last space of cleaned name)
OutCol = Right(OutCol, InStr(StrReverse(OutCol), " ") - 1)
End If
fGrabLName = OutCol
End Function
CODEPublic Function fGrabPrefix(InCol)
Dim OutCol As String
OutCol = InCol
'Check for "Mr. and Mrs.", "Dr. and Mrs."
If Left(OutCol, 12) Like ("*r. and Mrs.") Then
OutCol = Left(OutCol, 12)
'Check for same using ampersand
ElseIf Left(OutCol, 10) Like ("*r. & Mrs.") Then
OutCol = Left(OutCol, 10)
Else
'Check for nulls
If InStr(OutCol, " ") > 0 Then
'Extract prefix if present
Select Case Left(OutCol, InStr(OutCol, " ") - 1)
Case "Miss", "Mr.", "Ms.", "Mrs.", "Dr.", "Rev.", "Capt.", "Rabbi"
OutCol = Left(OutCol, InStr(OutCol, " ") - 1)
Case Else
OutCol = ""
End Select
Else
OutCol = ""
End If
End If
fGrabPrefix = OutCol
End Function
CODEPublic Function fGrabSuffix(InCol)
Dim OutCol As String
OutCol = InCol
'Check for Nulls
If InStr(OutCol, " ") > 0 Then
'Extract Suffix if present
Select Case Trim(Right(OutCol, InStr(StrReverse(OutCol), " ")))
Case "MD", "Jr.", "III", "IV", "V", "Jr", "M.D.", "DDS"
OutCol = Right(OutCol, InStr(StrReverse(OutCol), " ") - 1)
Case "Ret", "Ret."
'uses fTrimSuffix to get 'clean' name for first suffix
OutCol = Right(Trim(fTrimSuffix(OutCol)), InStr(StrReverse(OutCol), " ") - 2) & " " & _
Right(OutCol, InStr(StrReverse(OutCol), " ") - 1)
Case Else
OutCol = ""
End Select
Else
OutCol = ""
End If
fGrabSuffix = OutCol
End Function |
Talk To Other Members
