• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 871
  • Last Modified:

Excel: TranslateChar(StrIn as string) as string doesn't work for me

Dear experts,

In excel im trying to get this function from Matthewspatrick to work. If it works i think this is exactly what i would like to have! I am using excel 2010
 
Function TranslateChar(StrIn As String) As String
     
     ' This function may be used in Excel or Access, or in any VB/VBA project.
     
     ' Function evaluates an ANSI string that may have special characters, identified
     ' in the collection populated below.  If a special character is found, the function
     ' replaces that character with a designated replacement string (may be any number
     ' of characters).  There is no support for Unicode.
     
     ' The function conserves case, so if the special character is uppercase, then the
     ' first character of the replacement string will be uppercase as well.
     
     ' While the intent of this function is to "replace" characters with diacritical
     ' marks with their Roman alphabet equivalents (you should feel free to change the
     ' mapping below if you do not think it's right or it does not suit your purposes;
     ' I am no linguist).  However, you could use the code to replace any single ANSI
     ' character with whatever string you desire.
     
    Dim Counter As Long
    Dim coll As New Collection
    Dim Check As String
    Dim WasLower As Boolean
    Dim Letter As String
     
     ' See if the collection exists.  The collection is set up as a static variable, so
     ' that it will persist between function calls; that will save a few cycles on later
     ' function calls as there will be no need to create and populate the collection again.
     ' There wil be no "Set coll = Nothing" to release the object variable, though; we
     ' will rely on VBA to clean up the collection object for us when the user exits the
     ' application
     
If coll Is Nothing Then


         
       ' Set coll = New collection

        coll.Add Item:="A", Key:="À"
        coll.Add Item:="a", Key:="à"
        coll.Add Item:="A", Key:="Á"
        coll.Add Item:="a", Key:="á"
        coll.Add Item:="A", Key:="Â"
        coll.Add Item:="a", Key:="â"
        coll.Add Item:="a", Key:="ã"
        coll.Add Item:="A", Key:="Ã"
        coll.Add Item:="A", Key:="Ä"
        coll.Add Item:="a", Key:="ä"
        coll.Add Item:="A", Key:="Å "
        coll.Add Item:="a", Key:="å"
        
        coll.Add Item:="E", Key:="È"
        coll.Add Item:="e", Key:="è"
        coll.Add Item:="E", Key:="É"
        coll.Add Item:="e", Key:="é"
        coll.Add Item:="E", Key:="Ê"
        coll.Add Item:="e", Key:="ê"
        coll.Add Item:="E", Key:="Ë"
        coll.Add Item:="e", Key:="ë"
        coll.Add Item:="I", Key:="Ì"
        coll.Add Item:="i", Key:="ì "
        coll.Add Item:="I", Key:="Í"
        coll.Add Item:="i", Key:="í"
        
        coll.Add Item:="I", Key:="Î"
        coll.Add Item:="i", Key:="î"
        coll.Add Item:="I", Key:="Ï"
        coll.Add Item:="i", Key:="ï"

        coll.Add Item:="O", Key:="Ò"
        coll.Add Item:="o", Key:="ò"
        coll.Add Item:="O", Key:="Ó"
        coll.Add Item:="o", Key:="ó"
        coll.Add Item:="O", Key:="Ô"
        coll.Add Item:="o", Key:="ô"
        coll.Add Item:="O", Key:="Õ"
        coll.Add Item:="o", Key:="õ"
        coll.Add Item:="O", Key:="Ö"
        coll.Add Item:="o", Key:="ö"
        coll.Add Item:="O", Key:="Ø"
        coll.Add Item:="o", Key:="ø"
        coll.Add Item:="U", Key:="Ù"
        coll.Add Item:="u", Key:="ù"
        
        coll.Add Item:="U", Key:="Ú"
        coll.Add Item:="u", Key:="ú"
        coll.Add Item:="U", Key:="Ù"
        coll.Add Item:="u", Key:="ù"
        coll.Add Item:="U", Key:="Û"
        coll.Add Item:="u", Key:="û"
        coll.Add Item:="U", Key:="Ù"
        coll.Add Item:="u", Key:="ù"
        coll.Add Item:="U", Key:="Ü"
        coll.Add Item:="u", Key:="ü"
End If

     
     ' Loop through string to look for special characters needing replacement
     
    For Counter = 1 To Len(StrIn)
         
         ' Look in collection to see if the current character being considered is a "special"
         ' character
         
        On Error Resume Next
        Letter = Mid(StrIn, Counter, 1)
        Check = coll(Letter)
         
         ' Check to see if original character was upper or lower case
         
        WasLower = (StrComp(Letter, LCase(Letter), vbBinaryCompare) = 0)
        
         
         ' If there was no error, that means character was in collection and thus is a
         ' special character needing replacement
         
        If Err <> 0 Then
            Err.Clear
            Check = Letter
            
        End If
        On Error GoTo 0
         
         ' If character was lower case, return the translation in lower case.  If upper case,
         ' return in proper case (first character capitalized)
         
        TranslateChar = TranslateChar & IIf(WasLower, LCase(Check), StrConv(Check, vbProperCase))
    Next

End Function

Open in new window


I have put the function into a cell like: TranslateChar(D1)
in D1 there is a string like Øvre Røssaga and i want to get Ovre Rossaga.

I hope someone can help me,

Cheers,

MarkVrenken
0
MarkVrenken
Asked:
MarkVrenken
1 Solution
 
Patrick MatthewsCommented:
MarkVrenken,

It's not working because you've changed the code: you (or someone else) added the if structure around "coll Is Nothing" that is causing the collection to never get populated.

This version seems to work just fine:

Function TranslateChar(StrIn As String) As String

    ' This function may be used in Excel or Access, or in any VB/VBA project.
    
    ' Function evaluates an ANSI string that may have special characters, identified
    ' in the collection populated below.  If a special character is found, the function
    ' replaces that character with a designated replacement string (may be any number
    ' of characters).  There is no support for Unicode.
    
    ' The function conserves case, so if the special character is uppercase, then the
    ' first character of the replacement string will be uppercase as well.
    
    ' While the intent of this function is to "replace" characters with diacritical
    ' marks with their Roman alphabet equivalents (you should feel free to change the
    ' mapping below if you do not think it's right or it does not suit your purposes;
    ' I am no linguist).  However, you could use the code to replace any single ANSI
    ' character with whatever string you desire.
    
    Dim Counter As Long
    Dim coll As New Collection
    Dim Check As String
    Dim WasLower As Boolean
    Dim Letter As String
    
    ' Populate a Collection with the mapping.  The Key is the special character, and the
    ' Item is the replacement.  The key must always be a single character, but the item
    ' may be 1+ characters.  Use lower case in this list, and continue the list as
    ' needed.
    
    coll.Add Item:="a", Key:="á"
    coll.Add Item:="a", Key:="à"
    coll.Add Item:="a", Key:="â"
    coll.Add Item:="a", Key:="ã"
    coll.Add Item:="a", Key:="å"
    coll.Add Item:="a", Key:="ä"
    coll.Add Item:="ae", Key:="æ"
    coll.Add Item:="c", Key:="ç"
    coll.Add Item:="e", Key:="è"
    coll.Add Item:="e", Key:="é"
    coll.Add Item:="e", Key:="ê"
    coll.Add Item:="e", Key:="ë"
    coll.Add Item:="i", Key:="ì"
    coll.Add Item:="i", Key:="í"
    coll.Add Item:="i", Key:="î"
    coll.Add Item:="i", Key:="ï"
    coll.Add Item:="n", Key:="ñ"
    coll.Add Item:="o", Key:="ó"
    coll.Add Item:="o", Key:="ò"
    coll.Add Item:="o", Key:="õ"
    coll.Add Item:="o", Key:="ö"
    coll.Add Item:="o", Key:="ø"
    coll.Add Item:="oe", Key:="œ"
    coll.Add Item:="ss", Key:="ß" ' German sharp s
    coll.Add Item:="th", Key:="ð" ' Old English eth
    coll.Add Item:="th", Key:="þ" ' Old English thorn
    coll.Add Item:="u", Key:="ù"
    coll.Add Item:="u", Key:="ú"
    coll.Add Item:="u", Key:="û"
    coll.Add Item:="u", Key:="ü"
    coll.Add Item:="y", Key:="ý"
    coll.Add Item:="y", Key:="ÿ"
    
    ' Loop through string to look for special characters needing replacement
    
    For Counter = 1 To Len(StrIn)
        
        ' Look in collection to see if the current character being considered is a "special"
        ' character
        
        On Error Resume Next
        Letter = Mid(StrIn, Counter, 1)
        Check = coll(Letter)
        
        ' Check to see if original character was upper or lower case
        
        WasLower = (StrComp(Letter, LCase(Letter), vbBinaryCompare) = 0)
        
        ' If there was no error, that means character was in collection and thus is a
        ' special character needing replacement
        
        If Err <> 0 Then
            Err.Clear
            Check = Letter
        End If
        On Error GoTo 0
        
        ' If character was lower case, return the translation in lower case.  If upper case,
        ' return in proper case (first character capitalized)
        
        TranslateChar = TranslateChar & IIf(WasLower, LCase(Check), StrConv(Check, vbProperCase))
    Next
    
    ' Release object variable
    
    Set coll = Nothing
    
End Function

Open in new window


Patrick
0
 
MarkVrenkenAuthor Commented:
Dear Patrick,

Thanks very much. I found the code on this site http://www.vbaexpress.com/kb/getarticle.php?kb_id=917
with your name as programmer, But thanks for your help!! i tested the function and it now works !

Thanks a lot i will mark your answer as solution.

Mark
0

Featured Post

Get expert help—faster!

Need expert help—fast? Use the Help Bell for personalized assistance getting answers to your important questions.

Tackle projects and never again get stuck behind a technical roadblock.
Join Now