Results 1 to 11 of 11
  1. #1
    Star Lounger
    Join Date
    Jan 2003
    Location
    Manchester, Lancashire, England
    Posts
    92
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Selecting Initials (XP/2002)

    Is there an easy way of selecting the initial letters from names in a string? For example, "John Roger Charles Norman" to return "J R C N". I have an expression to do this but its very 'dense'

  2. #2
    Gold Lounger
    Join Date
    Jun 2001
    Location
    Crystal Beach, FL, Florida, USA
    Posts
    3,436
    Thanks
    1
    Thanked 34 Times in 34 Posts

    Re: Selecting Initials (XP/2002)

    There is no "easy" way (like a built-in function call). You will have to have some sort of loop that looks for the next blank character, then returns the next character. It shouldn't be too dense, but will require extra coding if you want to check for when you have 2 or more consecutive spaces, etc.
    Mark Liquorman
    See my website for Tips & Downloads and for my Liquorman Utilities.

  3. #3
    Bronze Lounger
    Join Date
    Nov 2001
    Location
    Arlington, Virginia, USA
    Posts
    1,394
    Thanks
    0
    Thanked 3 Times in 3 Posts

    Re: Selecting Initials (XP/2002)

    You would have to use a user-defined function for this. Example:

    Public Function SelectInitials(ByRef strTxt As String) As String

    Dim tmp As Variant
    Dim n As Long

    ' Use DO loop if text may have extra spaces between words:
    Do Until InStr(1, strTxt, Chr$(32) & Chr$(32), vbBinaryCompare) = 0
    strTxt = Replace(strTxt, Chr$(32) & Chr$(32), Chr$(32), , , vbBinaryCompare)
    Loop

    tmp = Split(strTxt, Chr$(32), , vbBinaryCompare)

    For n = 0 To UBound(tmp)
    tmp(n) = Left$(tmp(n), 1)
    Next n

    SelectInitials = Join(tmp, Chr$(32))

    Erase tmp

    End Function

    This example uses the Split function to create an array from a delimited text string (space delimited here), then uses Left function to get first character of each element in array, and finally uses Join function to concatenate array elements in a new string, with a space as delimiter. The Split and Join functions (available A2K or later) are useful for this type of task. Examples of use:

    ? SelectInitials("A B C")
    A B C

    ? SelectInitials("ALPHA BRAVO CHARLIE DELTA ECHO")
    A B C D E

    ? SelectInitials("ECHO FOXTROT GOLF HOTEL")
    E F G H

    Function can be modified as necessary.

    HTH

  4. #4
    Silver Lounger
    Join Date
    Jun 2001
    Location
    Niagara Falls, New York, USA
    Posts
    1,878
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Selecting Initials (XP/2002)

    Hi Mark

    Nice code!

    In addition to your eamples, how would you return:

    J B G for John B Gray Jr or
    T D B for Tom Douglas Brown Sr or
    J C S for Joe C Smith III

    Thanks, John

  5. #5
    Bronze Lounger
    Join Date
    Nov 2001
    Location
    Arlington, Virginia, USA
    Posts
    1,394
    Thanks
    0
    Thanked 3 Times in 3 Posts

    Re: Selecting Initials (XP/2002)

    You could modify sample function like this example:

    Public Function SelectInitialsRev(ByRef strTxt As String) As String

    Dim tmp As Variant
    Dim n As Long
    Dim strSuffix As String

    ' Use Do loop if there may be extra spaces in name, else comment out:
    ' Do Until InStr(1, strTxt, Chr$(32) & Chr$(32), vbBinaryCompare) = 0
    ' strTxt = Replace(strTxt, Chr$(32) & Chr$(32), Chr$(32), , , vbBinaryCompare)
    ' Loop

    strSuffix = Mid$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) + 1)

    If InStr(1, "JR.SR.IIIVIII", strSuffix, vbTextCompare) > 0 Then
    strTxt = Left$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) - 1)
    End If

    tmp = Split(strTxt, Chr$(32), , vbBinaryCompare)

    For n = 0 To UBound(tmp)
    tmp(n) = Left$(tmp(n), 1)
    Next n

    SelectInitialsRev = Join(tmp, Chr$(32))

    Erase tmp

    End Function

    Note: If your names or other text does not have extra spaces between names, you can comment out Do loop. Modified function uses Mid$ function to get last item in text string (InStrRev tests for last space), then tests to see if this item is found in string "JR.SR.IIIVIII" which covers most common suffixes (Jr, Sr, II, III, IV, V thru VIII) (modify if necessary). If suffix found use Left$ to exclude suffix, otherwise do not change original text. Some examples:

    ? SelectInitialsRev("John B Gray jr")
    J B G
    ? SelectInitialsRev("Thurston B Howell III")
    T B H
    ? SelectInitialsRev("George Herbert Walker Bush Sr.")
    G H W B
    ? SelectInitialsRev("Larry Mullen, Jr.")
    L M

    Note also, the If/Else suffix test uses InStr with vbTextCompare rather than vbBinaryCompare for comparison type, because text comparison is not case-sensitive, which is what you'd want in this case, since suffix may be Jr., JR, or whatever. For other tests (for space), default binary comparison is used, since case is not relevant and binary comparison is theoretically faster (not that you'd notice much difference....)

    HTH

  6. #6
    Bronze Lounger
    Join Date
    Nov 2001
    Location
    Arlington, Virginia, USA
    Posts
    1,394
    Thanks
    0
    Thanked 3 Times in 3 Posts

    Re: Selecting Initials (XP/2002)

    PS: It occurred to me, if you do NOT want spaces between the initials, modify the last line of function from:

    ' Space between initials:
    SelectInitialsRev = Join(tmp, Chr$(32))

    To this:

    ' No space between initials:
    SelectInitialsRev = Join(tmp, vbNullString)

    (The vbNullString constant is essentially same as "" (2 double quotes) but is easier to read.) The modified function produces following results:

    ? SelectInitialsRev("John Smith V")
    JS
    ? SelectInitialsRev("George Herbert Walker Bush Sr.")
    GHWB
    ? SelectInitialsRev("Joe C Smith III")
    JCS
    ? SelectInitialsRev("George W Bush")
    GWB

    HTH

  7. #7
    Silver Lounger
    Join Date
    Jun 2001
    Location
    Niagara Falls, New York, USA
    Posts
    1,878
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Selecting Initials (XP/2002)

    Hi Mark

    Nice code! dittos

    already did it with SelectInitials = Join(tmp, "")

    You do know what the next question is?

    In addition to your previous exmples, how would you return:

    J B G for Dr John B Gray Jr or
    T D B for Mr Tom Douglas Brown Sr or
    J C S for Miss Joette C Smith III

    Thanks, John

  8. #8
    Bronze Lounger
    Join Date
    Nov 2001
    Location
    Arlington, Virginia, USA
    Posts
    1,394
    Thanks
    0
    Thanked 3 Times in 3 Posts

    Re: Selecting Initials (XP/2002)

    <P ID="edit" class=small>(Edited by MarkD on 23-Oct-03 13:18. Modified sample code.)</P>I would add a "prefix test" for Mr., Mrs., etc similar to "suffix test." Modified function:

    Public Function SelectInitialsA(ByRef strTxt As String) As String

    Dim tmp As Variant
    Dim n As Long
    Dim strPrefix As String
    Dim strSuffix As String

    ' Use Do loop if there are extra spaces in name, else comment out:
    ' Do Until InStr(1, strTxt, Chr$(32) & Chr$(32), vbBinaryCompare) = 0
    ' strTxt = Replace(strTxt, Chr$(32) & Chr$(32), Chr$(32), , , vbBinaryCompare)
    ' Loop

    ' Get rid of possible leading/trailing spaces:
    strTxt = Trim$(strTxt)

    If InStr(1, strTxt, Chr$(32), vbBinaryCompare) > 0 Then

    strPrefix = Left$(strTxt, InStr(1, strTxt, Chr$(32), vbBinaryCompare) - 1)

    If InStr(1, "MR.MRS.MS.MISS.DR.PROF.", strPrefix, vbTextCompare) > 0 Then
    strTxt = Mid$(strTxt, InStr(1, strTxt, Chr$(32), vbBinaryCompare) + 1)
    End If

    strSuffix = Mid$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) + 1)

    If InStr(1, "JR.SR.IIIVIIIMDM.D.PH.D.PHD", strSuffix, vbTextCompare) > 0 Then
    strTxt = Left$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) - 1)
    End If

    tmp = Split(strTxt, Chr$(32), , vbBinaryCompare)

    For n = 0 To UBound(tmp)
    tmp(n) = Left$(tmp(n), 1)
    Next n

    ' Space between initials:
    SelectInitialsA = Join(tmp, Chr$(32))
    ' No space between initials:
    ' SelectInitialsA = Join(tmp, vbNullString)
    Erase tmp
    Else
    SelectInitialsA = Left$(strTxt, 1)
    End If

    End Function

    Note added some additional strings to suffix to test for MD, etc. The prefix & suffix test strings can be modified as necessary to test for any other possibilities. Also added use of Trim$ function to get rid of any possible leading/trailing spaces, and tested to see if text string had any spaces to avoid error if single name passed to function. Example of use:

    ? SelectInitialsA("Mr. John A. Smith")
    J A S
    ? SelectInitialsA("Mrs. John A. Smith, JR.")
    J A S
    ? SelectInitialsA("Dr Billy Bob Sawbones, M.D.")
    B B S
    ? SelectInitialsA("Prof. Jack Jones, Ph.D.")
    J J
    ? SelectInitialsA("Madonna ")
    M

    HTH

  9. #9
    Silver Lounger
    Join Date
    Jun 2001
    Location
    Niagara Falls, New York, USA
    Posts
    1,878
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Selecting Initials (XP/2002)

    Hi Mark

    Nice code! dittos again

    And for the final tweak!

    A way to add tbl_PrefixSuffix table that user could add their own Prefix's and Suffix's

    Field Name:

    EliminateWord

    Dr
    Mr
    Miss
    Jr
    Sr
    III
    etc

    To remove hard coding in the following:

    strPrefix = Left$(strTxt, InStr(1, strTxt, Chr$(32), vbBinaryCompare) - 1)

    If InStr(1, "MR.MRS.MS.MISS.DR.PROF.", strPrefix, vbTextCompare) > 0 Then
    strTxt = Mid$(strTxt, InStr(1, strTxt, Chr$(32), vbBinaryCompare) + 1)
    End If

    strSuffix = Mid$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) + 1)

    If InStr(1, "JR.SR.IIIVIIIMDM.D.PH.D.PHD", strSuffix, vbTextCompare) > 0 Then
    strTxt = Left$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) - 1)
    End If

    Thanks, John

  10. #10
    Bronze Lounger
    Join Date
    Nov 2001
    Location
    Arlington, Virginia, USA
    Posts
    1,394
    Thanks
    0
    Thanked 3 Times in 3 Posts

    Re: Selecting Initials (XP/2002)

    That's probably a good idea. To test this I created 2 tables, each with a single field: Prefixes table (Prefix field) and Suffixes table (Suffix field). Revised function so that the prefix & suffix test strings are passed to function as arguments:

    Public Function SelectInitialsB(ByRef strTxt As String, _
    ByRef strPrefixes As String, _
    ByRef strSuffixes As String) As String
    Dim tmp As Variant
    Dim n As Long
    Dim strPrefix As String
    Dim strSuffix As String

    ' Get rid of possible leading/trailing spaces:
    strTxt = Trim$(strTxt)

    ' Test to see if strTxt contains at least one space:
    If InStr(1, strTxt, Chr$(32), vbBinaryCompare) > 0 Then

    strPrefix = Left$(strTxt, InStr(1, strTxt, Chr$(32), vbBinaryCompare) - 1)
    If InStr(1, strPrefixes, strPrefix, vbTextCompare) > 0 Then
    strTxt = Mid$(strTxt, InStr(1, strTxt, Chr$(32), vbBinaryCompare) + 1)
    End If

    strSuffix = Mid$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) + 1)
    If InStr(1, strSuffixes, strSuffix, vbTextCompare) > 0 Then
    strTxt = Left$(strTxt, InStrRev(strTxt, Chr$(32), , vbBinaryCompare) - 1)
    End If

    tmp = Split(strTxt, Chr$(32), , vbBinaryCompare)

    For n = 0 To UBound(tmp)
    tmp(n) = Left$(tmp(n), 1)
    Next n

    ' Space between initials:
    SelectInitialsB = Join(tmp, Chr$(32))
    ' No space between initials:
    ' SelectInitialsB = Join(tmp, vbNullString)
    Erase tmp
    Else
    ' No spaces in strTxt
    SelectInitialsB = Left$(strTxt, 1)
    End If

    End Function

    To generate the strPrefixes & strSuffixes string arguments, you can use the ADO Recordset GetString method, which returns the data returned by a recordset as a string. Example:

    Public Function GetStringFromRst(ByRef strFld As String, _
    ByRef strTbl As String) As String
    On Error GoTo Err_Handler

    Dim rst As ADODB.Recordset
    Dim strMsg As String
    Dim strSQL As String

    Set rst = New ADODB.Recordset
    strSQL = "SELECT <!t>[" & strFld & "]<!/t> FROM <!t>[" & strTbl & "]<!/t> ORDER BY <!t>[" & strFld & "]<!/t>;"
    rst.Open strSQL, CurrentProject.Connection, adOpenStatic, adLockOptimistic
    GetStringFromRst = rst.GetString(adClipString, , vbNullString, Chr$(32))
    rst.Close

    Exit_Sub:
    Set rst = Nothing
    Exit Function
    Err_Handler:
    strMsg = "Error No " & Err.Number & ": " & Err.Description
    MsgBox strMsg, vbExclamation, "GET STRING ERROR MESSAGE"
    Resume Exit_Sub
    End Function

    Note that you'd open a static recordset, and in this case use space as row delimiter (the default is a carriage return). Test results with Prefix & Suffix tables:

    ? GetStringFromRst("Prefix", "Prefixes")
    DR. MISS MR. MRS. MS. PROF.
    ? GetStringFromRst("Suffix", "Suffixes")
    II III IV JR M.D. MD PH.D. PHD. SR V VI VII VIII

    Convoluted example of combining these functions in one expression:

    ? SelectInitialsB("Dr J. Jonah Jameson, Ph.D",GetStringFromRst("Prefix","Prefixes"),GetStr ingFromRst("Suffix","Suffixes"))
    J J J

    If you will be calling the SelectInitials function repeatedly, it'd be good idea to generate the strPrefixes & strSuffixes strings only once, using GetString function as illustrated. For example, if running code from a form, save the prefix and suffix test strings in a textbox, so you don't have to repeatedly open & close a recordset to get these values.

    HTH

  11. #11
    Silver Lounger
    Join Date
    Jun 2001
    Location
    Niagara Falls, New York, USA
    Posts
    1,878
    Thanks
    0
    Thanked 0 Times in 0 Posts

    Re: Selecting Initials (XP/2002)

    Hi Mark

    Don't panic! No more request. At this time anyway.

    Attached is DB with your solutions recapped.

    Thanks for you help, I learned a lot, others might be interested.

    John
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •