The NEATCODE.MDB available at
http://support.microsoft.com/kb/148402/EN-US/
has name parsing code (and much more, you can learn a lot from the
example code) This may have a bit more than what you need, but these
will let you extract first and last name from a string. You could also
get Title, Degree or Pedigree by making functions similar to lastname
and firstname.
It's probably not horribly efficient, but I've used it for name
clean-up for years.
Function lastname(NS As String)
Dim Title As String
Dim FName As String
Dim MName As String
Dim LName As String
Dim Pedigree As String
Dim Degree As String
Call ParseName(NS, Title, FName, MName, LName, Pedigree, Degree)
lastname = LName
End Function
Function firstname(NS As String)
Dim Title As String
Dim FName As String
Dim MName As String
Dim LName As String
Dim Pedigree As String
Dim Degree As String
Call ParseName(NS, Title, FName, MName, LName, Pedigree, Degree)
firstname = FName
End Function
Function shortname(NS As String)
Dim Title As String
Dim FName As String
Dim MName As String
Dim LName As String
Dim Pedigree As String
Dim Degree As String
Call ParseName(NS, Title, FName, MName, LName, Pedigree, Degree)
shortname = Left(Left(FName, 1) & " " & LName & "
", 15)
End Function
Sub ParseName(ByVal s As String, Title As String, FName As String,
MName As String, LName As String, Pedigree As String, Degree As String)
'
' Parses name "Mr. Bill A. Jones III, PhD" into separate fields.
' Words are extracted in the following order: Title, Degree, Pedigree,
LName, FName, MName
' Assumes Pedigree is not preceded by a comma, or else it will end up
with the Degree(s).
'
Dim Word As String, P As Integer, Found As Integer
Const Titles =
"Mr.Mrs.Ms.Dr.Mme.Mssr.Mister,Miss,Doctor,Sir,Lord ,Lady,Madam,Mayor,President"
Const Pedigrees = "Jr.Sr.III,IV,VIII,IX,XIII"
Title = ""
FName = ""
MName = ""
LName = ""
Pedigree = ""
Degree = ""
'
' Get Title
'
Word = CutWord(s, s)
If InStr(Titles, Word) Then
Title = Word
Else
s = Word & " " & s
End If
'
' Get Degree
'
P = InStr(s, ",")
If P > 0 Then
Degree = Trim$(Mid$(s, P + 1))
s = Trim$(Left$(s, P - 1))
End If
'
' Get Pedigree
'
Word = CutLastWord(s, s)
If InStr(Pedigrees, Word) Then
Pedigree = Word
Else
s = s & " " & Word
End If
'
' Get Last Name
'
LName = CutLastWord(s, s)
'
' Get First Name
'
FName = CutWord(s, s)
'
' Get Middle Name(s)
'
MName = Trim(s)
End Sub
Sub TestParseName()
Dim N As String, t As String, f As String, M As String, L As String, P
As String, D As String
N = "Dr. James George William Joyce-Brothers IV, MS, PhD"
ParseName N, t, f, M, L, P, D
Debug.Print t, f, M, L, P, D
N = "New York NY 45678-9876"
ParseCSZ N, t, f, M
Debug.Print t, f, M
End Sub
Function CountCSVWords(s) As Integer
'
' Counts words in a string separated by commas
'
Dim WC As Integer, Pos As Integer
If VarType(s) <> 8 Or Len(s) = 0 Then
CountCSVWords = 0
Exit Function
End If
WC = 1
Pos = InStr(s, ",")
Do While Pos > 0
WC = WC + 1
Pos = InStr(Pos + 1, s, ",")
Loop
CountCSVWords = WC
End Function
Function CountSWords(s, delimiter As String) As Integer
'
' Counts words in a string separated by commas
'
Dim WC As Integer, Pos As Integer
If VarType(s) <> 8 Or Len(s) = 0 Then
CountSWords = 0
Exit Function
End If
WC = 1
Pos = InStr(s, delimiter)
Do While Pos > 0
WC = WC + 1
Pos = InStr(Pos + 1, s, delimiter)
Loop
CountSWords = WC
End Function
Function CountWords(s) As Integer
'
' Counts words in a string separated by 1 or more spaces
'
Dim WC As Integer, i As Integer, OnASpace As Integer
If VarType(s) <> 8 Or Len(Trim(s)) = 0 Then
CountWords = 0
Exit Function
End If
WC = 0
OnASpace = True
For i = 1 To Len(s)
If Mid(s, i, 1) = " " Then
OnASpace = True
Else
If OnASpace Then
OnASpace = False
WC = WC + 1
End If
End If
Next i
CountWords = WC
End Function
Function CutFirstWord(s, Remainder)
'
' CutWord: returns the first word in S.
' Remainder: returns the rest.
'
' Words are delimited by spaces
'
Dim temp, i As Integer, P As Integer
temp = Trim(s)
P = InStr(temp, " ")
If P = 0 Then
CutFirstWord = temp
Remainder = Null
Else
CutFirstWord = Left(temp, P - 1)
Remainder = Trim(Mid(temp, P + 1))
End If
End Function
Function CutLastWord(s, Remainder)
'
' CutWord: returns the first word in S.
' Remainder: returns the rest.
'
' Words are delimited by spaces
'
Dim temp, i As Integer, P As Integer
temp = Trim(s)
P = 1
For i = Len(temp) To 1 Step -1
If Mid(temp, i, 1) = " " Then
P = i + 1
Exit For
End If
Next i
If P = 1 Then
CutLastWord = temp
Remainder = Null
Else
CutLastWord = Mid(temp, P)
Remainder = Trim(Left(temp, P - 1))
End If
End Function
Function CutWord(s, Remainder)
'
' CutWord: returns the first word in S.
' Remainder: returns the rest.
'
Dim temp, P As Integer
temp = Trim(s)
P = InStr(temp, " ")
If P = 0 Then P = Len(temp) + 1
CutWord = Left(temp, P - 1)
Remainder = Trim(Mid(temp, P + 1))
End Function
Function GetCSVWord(s, Indx As Integer)
Dim WC As Integer, Count As Integer, SPos As Integer, EPos As Integer
WC = CountCSVWords(s)
If Indx < 1 Or Indx > WC Then
GetCSVWord = Null
Exit Function
End If
Count = 1
SPos = 1
For Count = 2 To Indx
SPos = InStr(SPos, s, ",") + 1
Next Count
EPos = InStr(SPos, s, ",") - 1
If EPos <= 0 Then EPos = Len(s)
GetCSVWord = Mid(s, SPos, EPos - SPos + 1)
End Function
Function GetSWord(s, delimiter As String, Indx As Integer)
Dim WC As Integer, Count As Integer, SPos As Integer, EPos As Integer
WC = CountSWords(s, delimiter)
Select Case Indx
Case Is = 0
GetSWord = s
Exit Function
Case Is < 1
GetSWord = Null
Exit Function
Case Is > WC
GetSWord = Null
Exit Function
End Select
Count = 1
SPos = 1
For Count = 2 To Indx
SPos = InStr(SPos, s, delimiter) + Len(delimiter)
Next Count
EPos = InStr(SPos, s, delimiter) - Len(delimiter)
If EPos <= 0 Then EPos = Len(s)
GetSWord = Trim(Mid(s, SPos, EPos - SPos + Len(delimiter)))
End Function
Function GetWord(s, Indx As Integer)
'
' Extracts a word in text where words are separated by 1 or more spaces
'
Dim i As Integer, WC As Integer, Count As Integer, SPos As Integer,
EPos As Integer, OnASpace As Integer
WC = CountWords(s)
If Indx < 1 Or Indx > WC Then
GetWord = Null
Exit Function
End If
Count = 0
OnASpace = True
For i = 1 To Len(s)
If Mid(s, i, 1) = " " Then
OnASpace = True
Else
If OnASpace Then
OnASpace = False
Count = Count + 1
If Count = Indx Then
SPos = i
Exit For
End If
End If
End If
Next i
EPos = InStr(SPos, s, " ") - 1
If EPos <= 0 Then EPos = Len(s)
GetWord = Mid(s, SPos, EPos - SPos + 1)
End Function
