Go Premium for a chance to win a PS4. Enter to Win

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 206
  • Last Modified:

Parsing - YUK! 1 Name field into 3

I need to parse a name field into a more up-to-date format into a Prefix, firstname, and lastname.  The information is currently in an ACCESS table with only ONE NAME FIELD having data as such.

Mr. Michael R. Smith
Dr. E Ralph
Ms. Edith Campbell
Col. Ronald McDonald
Capt Amnezia
R. A. R. Front
A. Moth
Mrs. Betz
(The_Company_Name)

I need it parsed into 3 different fields to show as follows:

"Mr.","Michael R.","Smith"
"Ms.","Edit","Campbell"
"Col.","Ronald","McDonald"
"Capt.","Amnezia"
"","R. A. R.","Front"
"","A.","Moth"
"Mrs.","Betz"
"","","The Company Name"


Which Means
1) It needs to know what prefixes are Mr. Mrs. Miss Ms., Capt., Col., Rev., (this is the list)

2)  It needs to include first and/or middle initials in the firstname field.

3) The company name usually has no spaces in it (thus the underscore) so the brackets need to be deleted (if they exist in the field) and the underscores replaced with spaces (I can do this part I think)

It's quite a bit of logic here.. Not sure how or where to start.

I am outputting it to a text file so that somebody else's program can bring it in.


Open "C:\temp\namelist.txt" For Output As #intnumfile

With Data1.Recordset
 Do Until .EOF


I get lost at this point


At the end there are other parts of the file that I have already parsed and added to the line below:

Print #intnumfile, Chr$(34) & "3" & Chr$(34); "," &  ----- etc, etc.

0
trudymaresch
Asked:
trudymaresch
  • 7
  • 6
  • 3
  • +2
1 Solution
 
gencrossCommented:
Here is a function that I wrote to handle something like this, except I only needed the Last name, first initial.  I tested it with a format that you will need and it does not work, but you can see the logic and modify it.  I don't know of an easy way to do this, but this could be a good starting point for you.  Hope it helps.

Private Sub ParseSignature(strSig As String, sretFirstInt As String, sretLastName As String, Optional bReverse As Boolean)
   
    Dim intSpacePos As Integer
    Dim sTemp As String
    Dim sTemp2 As String
    Dim sRevLast As String
   
    On Error GoTo ParseSignature_Error
   
    'Get last name
    intSpacePos = InStr(1, strSig, " ")
    sTemp = strSig
    If intSpacePos > 0 Then
       
        'If InStr(strSig, ",") Then
        '    sretFirstInt = Trim(Mid(strSig, InStr(strSig, ",") + 1, 1))
        'End If
       
        If intSpacePos = 2 Then
            sretFirstInt = Left(strSig, 1)
            sTemp = Trim(Mid(strSig, intSpacePos + 1))
            intSpacePos = InStr(1, sTemp, " ")
            sTemp = Trim(Mid(sTemp, intSpacePos + 1))
           
            If InStr(sTemp, " ") Then
                sretLastName = Trim(Mid(sTemp, 1, InStr(sTemp, " ") - 1))
            Else
                sretLastName = sTemp
            End If
           
            Exit Sub
        Else
           
            sretFirstInt = Left(sTemp, 1)
            sRevLast = Left(sTemp, InStr(sTemp, " ") - 1)
           
            sTemp2 = Trim(Mid(sTemp, intSpacePos + 1))
           
            If InStr(sTemp2, " ") = 2 Then
                sTemp = Trim(Mid(sTemp2, InStr(sTemp2, " ") + 1))
                If InStr(sTemp, " ") = 0 Then
                    sretLastName = Trim(sTemp)
                Else
                    sretLastName = Trim(Left(sTemp, InStr(sTemp, " ") - 1))
                End If
            ElseIf InStr(sTemp2, " ") = 0 Then
                sretLastName = sTemp2
                Exit Sub
            Else
                sTemp = Trim(Mid(sTemp2, InStr(sTemp2, " ") + 1))
               
                If InStr(sTemp, " ") <> 0 Then
                    sretLastName = Trim(Left(sTemp, InStr(sTemp, " ") - 1))
                Else
                    sretLastName = sTemp
                    Select Case Left(sTemp2, 2)
                        Case "MD", "DC"
                            sretLastName = sTemp
                        Case Else
                            sretLastName = Trim(Left(sTemp2, InStr(sTemp2, " ") - 1))
                    End Select
                End If
            End If
            'Exit Sub
        End If
       
        If InStr(sretFirstInt, " ") > 0 Then
            sTemp = Mid(sretFirstInt, InStr(sretFirstInt, " ") + 1)
            If Len(sTemp2) = 1 Then
                 sretFirstInt = Left(sretFirstInt, 1)
            End If
        Else
            sretFirstInt = Left(sretFirstInt, 1)
        End If
       
    Else            'no spaces found
       sretLastName = strSig
    End If
   
    If bReverse Then
        sTemp = sretLastName
        sretLastName = sRevLast
        sretFirstInt = Left(sTemp, 1)
    End If
   
ParseSignature_Exit:
   
    Exit Sub
   
ParseSignature_Error:
   
    Resume ParseSignature_Exit
    MsgBox Err.Description, vbCritical, "ParseSignature"
    Resume
   
End Sub
0
 
gencrossCommented:
Another Note. This function will return M Smith if it is passed for example "Michael R Smith".  You could just as some logic for the title and expand it to return the entire full name and middle init.
0
 
trudymareschAuthor Commented:
- wow that was fast! I'll have a look. - Thanks
0
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
bobbit31Commented:
some sample code, not tested... i'm going to do that now

Dim arrPrefix(7) as String
Dim arrNames() as String
Dim newName(3) as String
Dim blnFoundPrefix as Boolean

arrPrefix(0) = "Mr."
arrPrefix(0) = "Mrs."
arrPrefix(0) = "Miss"
arrPrefix(0) = "Ms."
arrPrefix(0) = "Capt."
arrPrefix(0) = "Col."
arrPrefix(0) = "Rev."

newName(0) = Chr$(34) & Chr$(34)
newName(1) = Chr$(34) & Chr$(34)
newName(2) = Chr$(34) & Chr$(34)

arrNames = Split(strText)

   if i = 0 then '' check if it's a prefix
        blnFoundPrefix = false
        for j = 0 to UBound(arrPrefix)
            if arrPrefix(j) = arrNames(i) then
                 blnFoundPrefix = true
                 newName(0) = arrNames(i)
                 exit for
            end if
        next
        if blnFoundPrefix <> true then '' not a prefix
            '' find out how many words there were
            if UBound(arrNames) = 1 then '' it's alone so
                 newName(2) = Chr$(34) & arrNames(i) & Chr$(34)
            else if UBound(arrNames) = 2 then '' it's a first and last name
                 newName(1) = Chr$(34) & arrNames(0) & Chr$(34)
                 newName(2) = Chr$(34) & arrNames(1) & Chr$(34)
            end if
        end if

'' set up the output string
strNewName = newName(0) & "," & newName(1) & "," & newName(2)

Print #intnumfile, strNewName
                 

                             
0
 
rspahitzCommented:
>It's quite a bit of logic here.. Not sure how or where to start.

As pointed out by bobbit31, I think you should start by concentrating your efforts on splitting the entries into space-delimited fields.  From there, check each field to determine the format.

For example, if the first field is the only field, it may be a company.  (Could it be anything else?)

Otherwise, check to see if it's a title.  If so, throw it into a title area.

Of the remainder, the last field should be the last name, if that's not the only field remaining, the first field is the first name, and any middle field(s) are the middle names.

--
Basically, categorize the parts and drop them into the right "buckets".  Start with the simplest option (single-field means company) and as you eliminate those, what remains is easier to deal with.
0
 
bobbit31Commented:
btw, disregard my previous post, i'm working on a new one and actually testing it this time ;) almost got it
0
 
bobbit31Commented:
try this:

Private Sub Command1_Click()

    MsgBox parseName("Mr. Michael R. Smith")
    MsgBox parseName("Dr. E Ralph")
    MsgBox parseName("Ms. Edith Campbell")
    MsgBox parseName("Col. Ronald McDonald")
    MsgBox parseName("R. A. R. Front")
    MsgBox parseName("The_Company_Name")
    MsgBox parseName("Mrs. Betz")

End Sub

Private Function parseName(strName As String) As String

Dim arrNames() As String
Dim arrPrefix(7) As String
Dim newName(3) As String
Dim blnFoundPrefix As Boolean

arrPrefix(0) = "Mr."
arrPrefix(1) = "Mrs."
arrPrefix(2) = "Miss"
arrPrefix(3) = "Ms."
arrPrefix(4) = "Capt."
arrPrefix(5) = "Col."
arrPrefix(6) = "Rev."
arrPrefix(7) = "Dr."

newName(0) = ""
newName(1) = ""
newName(2) = ""

arrNames = Split(strName)

numWords = UBound(arrNames) + 1

Select Case numWords
   
    Case 1: '' only one word, only one option (put in third position)
        newName(0) = Chr$(34) & Chr$(34) & ","
        newName(1) = Chr$(34) & Chr$(34) & ","
        newName(2) = Chr$(34) & arrNames(0) & Chr$(34)
       
    Case 2: '' two words, two options
        '' check if there's a prefix
        blnFoundPrefix = False
        For i = 0 To UBound(arrPrefix)
            If arrNames(0) = arrPrefix(i) Then
                blnFoundPrefix = True
                Exit For
            End If
        Next
       
        If blnFoundPrefix Then
            newName(0) = Chr$(34) & arrNames(0) & Chr$(34) & ","
            newName(1) = Chr$(34) & arrNames(1) & Chr$(34)
        Else
            newName(0) = Chr$(34) & Chr$(34) & ","
            newName(1) = Chr$(34) & arrNames(0) & Chr$(34) & ","
            newName(2) = Chr$(34) & arrNames(1) & Chr$(34)
        End If
       
    Case Else: '' three or more, so check for initials
        '' check if there's a prefix
        blnFoundPrefix = False
        For i = 0 To UBound(arrPrefix)
            If arrNames(0) = arrPrefix(i) Then
                blnFoundPrefix = True
                Exit For
            End If
        Next
       
        newName(1) = Chr$(34)
        If blnFoundPrefix Then
            newName(0) = Chr$(34) & arrNames(0) & Chr$(34) & ","
        Else
            newName(0) = Chr$(34) & Chr$(34) & ","
            newName(1) = newName(1) & arrNames(0)
        End If
       
        '' basically add everything in the middle to first name
        '' when we get to the last word, we have the last name and we are
        '' done.  Assuming that there is always a last name. if not let me know
        numWords = numWords - 1 '' i added 1 earlier
        For j = 1 To numWords
            If j = numWords Then '' it's the last one, must be last name?
                newName(2) = Chr$(34) & arrNames(j) & Chr$(34)
            Else
                newName(1) = newName(1) & " " & arrNames(j)
            End If
        Next
        newName(1) = newName(1) & Chr$(34) & ","
       
End Select

'' set up the output string
For i = 0 To UBound(newName)
    If newName(i) <> "" Then
        strNewName = strNewName & newName(i)
    End If
Next
parseName = strNewName

End Function

it does make some assumptions (which i put in comments)
let me know if you need tweaking (which you probably will).

0
 
bobbit31Commented:
also, shouldn't "Mrs. Betz" parse out to "Mrs.", "", "Betz"

if so, you can remove the Case 2
0
 
trudymareschAuthor Commented:
You are currect about the Parsing on Mrs. Betz - sorry about that typo.

Thanks
I'll remove case 2
0
 
rspahitzCommented:
As I look further at your results, I see that the logic is actually pretty simply:

1) Split the name at the spaces
2) Pull off the last item and place into the third field (modifying as necessary if it's a company)
3) Pull off the first item and see if it matches a predefined title.
a) If so, place into the first field and put the rest (joined) into the second field
b) If not, place it with the rest (joined) into the second field.
0
 
trudymareschAuthor Commented:
rspahitz
Basically - that is it in a nutshell - I tried splitting at the spaces and kept getting duplication in the parse.

bobbit31 - I took out case 2 and got an error.  
0
 
trudymareschAuthor Commented:
bobbit31 - disregard last message - fixed my error
0
 
rspahitzCommented:
bobbit's code looks good...just one suggestion is to replace all chr$(34) with vbDoubleQuote and define it at the top of the sub as:

Const vbDoubleQuote as string * 1 = """"
0
 
trudymareschAuthor Commented:
Hi Bobbit - works great -except there is a blank space showing up before the first name... (except in the case of R. A. R. Front)

I'm trying to figure out why - any help would be appreciated.
0
 
bobbit31Commented:
replace newName(1) = newName(1) & " " & arrNames(j)

with          

                If j = 1 Then
                    newName(1) = newName(1) & arrNames(j)
                Else
                    newName(1) = newName(1) & " " & arrNames(j)
                End If
0
 
trudymareschAuthor Commented:
I think it is working - now to try to import it into the other program - here goes

Thanks for all your help I think I will be awarding points shortly.
0
 
bobbit31Commented:
glad to help!
0
 
mlmccCommented:
listening
0
 
trudymareschAuthor Commented:
Thank you! It works beautifully.
0

Featured Post

VIDEO: THE CONCERTO CLOUD FOR HEALTHCARE

Modern healthcare requires a modern cloud. View this brief video to understand how the Concerto Cloud for Healthcare can help your organization.

  • 7
  • 6
  • 3
  • +2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now