Code to remove all diacritics

RobiNew · #1 11-02-2025, 08:18 AM

Hi! Can someone help me with this code?
Sub RemoveDiacriticsFromName()
Dim Name As String
Name = "Túró" 'This is just an example
'Here: Insert code (not function) to remove all diacritics from any Name
MsgBox Name (= Turo)

End Sub

macropod · #2 11-02-2025, 02:45 PM

What you're trying to replace is accents, not diacritics.

Not sure what you've got against a function. For example:

Code:

Sub Test()
MsgBox RemoveAccents("Túró") 'This is just an example
End Sub

Function RemoveAccents(StrNm As String) As String
Dim i As Long, ArrFnd, ArrRep
ArrFnd = Array("À", "Á", "Â", "Ã", "Ä", "Å", "Æ", "Ç", "È", "É", "Ê", "Ë", _
"Ì", "Í", "Î", "Ï", "Ð", "Ñ", "Ò", "Ó", "Ô", "Õ", "Ö", "Ø", "Ù", "Ú", "Û", _
"Ü", "Ý", "à", "á", "â", "ã", "ä", "å", "æ", "ç", "è", "é", "ê", "ë", "ì", _
"í", "î", "ï", "ð", "ñ", "ò", "ó", "ô", "õ", "ö", "ø", "ù", "ú", "û", "ü", "ý", "ÿ")
ArrRep = Array("A", "A", "A", "A", "A", "A", "AE", "C", "E", "E", "E", "E", _
"I", "I", "I", "I", "D", "N", "O", "O", "O", "O", "O", "O", "U", "U", "U", _
"U", "Y", "a", "a", "a", "a", "a", "a", "ae", "c", "e", "e", "e", "e", "i", _
"i", "i", "i", "o", "n", "o", "o", "o", "o", "o", "o", "u", "u", "u", "u", "y", "y")
For i = 0 To UBound(ArrFnd)
  StrNm = Replace(StrNm, ArrFnd(i), ArrRep(i))
Next
RemoveAccents = StrNm
End Function

Sure, it could be done without a function, but having a function makes it easier to call from anywhere in your code - and is more portable than something hard-coded into a sub.

vivka · #3 11-02-2025, 03:24 PM

Hi, RobiNew! Not elegant but works. I couldn't make VBA see Array() or Split() functions with diacritics or their Uncodes however I tried. So I came up with this "primitive" code.

Code:

Sub RemoveDiacritics()

Dim rng As range
    
    Set rng = Selection.range
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .text = ChrW(192)
        .Replacement.text = "A"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
        .text = ChrW(193)
        .Replacement.text = "A"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(194)
        .Replacement.text = "A"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(195)
        .Replacement.text = "A"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(196)
        .Replacement.text = "A"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(197)
        .Replacement.text = "A"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(198)
        .Replacement.text = "A"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(200)
        .Replacement.text = "E"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(201)
        .Replacement.text = "E"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(202)
        .Replacement.text = "E"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(203)
        .Replacement.text = "E"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(204)
        .Replacement.text = "I"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(205)
        .Replacement.text = "I"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(206)
        .Replacement.text = "I"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(207)
        .Replacement.text = "I"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(209)
        .Replacement.text = "N"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(210)
        .Replacement.text = "O"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(211)
        .Replacement.text = "O"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(212)
        .Replacement.text = "O"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(213)
        .Replacement.text = "O"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(214)
        .Replacement.text = "O"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(217)
        .Replacement.text = "U"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(218)
        .Replacement.text = "U"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(219)
        .Replacement.text = "U"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(220)
        .Replacement.text = "U"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(221)
        .Replacement.text = "Y"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(224)
        .Replacement.text = "a"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(225)
        .Replacement.text = "a"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(226)
        .Replacement.text = "a"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(227)
        .Replacement.text = "a"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(228)
        .Replacement.text = "a"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(229)
        .Replacement.text = "a"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(232)
        .Replacement.text = "e"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(233)
        .Replacement.text = "e"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(234)
        .Replacement.text = "e"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(235)
        .Replacement.text = "e"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(236)
        .Replacement.text = "i"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(2374)
        .Replacement.text = "i"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(238)
        .Replacement.text = "i"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(241)
        .Replacement.text = "n"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(242)
        .Replacement.text = "o"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(243)
        .Replacement.text = "o"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(244)
        .Replacement.text = "o"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(245)
        .Replacement.text = "o"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(246)
        .Replacement.text = "o"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(249)
        .Replacement.text = "u"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(250)
        .Replacement.text = "u"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(251)
        .Replacement.text = "u"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(252)
        .Replacement.text = "u"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(253)
        .Replacement.text = "y"
        .Execute Replace:=wdReplaceAll
        .text = ChrW(255)
        .Replacement.text = "y"
        .Execute Replace:=wdReplaceAll
End With
End Sub

macropod · #4 11-02-2025, 07:05 PM

Quote:

Originally Posted by vivka

Hi, RobiNew! Not elegant but works. I couldn't make VBA see Array() or Split() functions with diactritics or their Uncodes however I tried.

The code I posted could easily be adapted for that, but that doesn't seem to be what the OP is after.

For example:

Code:

Sub RemoveAccents()
Application.ScreenUpdating = False
Dim i As Long, ArrFnd, ArrRep
ArrFnd = Array("À", "Á", "Â", "Ã", "Ä", "Å", "Æ", "Ç", "È", "É", "Ê", "Ë", _
"Ì", "Í", "Î", "Ï", "Ð", "Ñ", "Ò", "Ó", "Ô", "Õ", "Ö", "Ø", "Ù", "Ú", "Û", _
"Ü", "Ý", "à", "á", "â", "ã", "ä", "å", "æ", "ç", "è", "é", "ê", "ë", "ì", _
"í", "î", "ï", "ð", "ñ", "ò", "ó", "ô", "õ", "ö", "ø", "ù", "ú", "û", "ü", "ý", "ÿ")
ArrRep = Array("A", "A", "A", "A", "A", "A", "AE", "C", "E", "E", "E", "E", _
"I", "I", "I", "I", "D", "N", "O", "O", "O", "O", "O", "O", "U", "U", "U", _
"U", "Y", "a", "a", "a", "a", "a", "a", "ae", "c", "e", "e", "e", "e", "i", _
"i", "i", "i", "o", "n", "o", "o", "o", "o", "o", "o", "u", "u", "u", "u", "y", "y")
With ActiveDocument.Range.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .MatchCase = True
  For i = 0 To UBound(ArrFnd)
    .Execute FindText:=ArrFnd(i), ReplaceWith:=ArrRep(i), Replace:=wdReplaceAll
  Next
End With
Application.ScreenUpdating = True
End Sub

RobiNew · #5 Yesterday, 12:29 AM

Many thanks for your suggestions! This is not exactly what I need, but I'm going to work on it and then let you know.

vivka · #6 Yesterday, 01:59 AM

Replacing diacritics with their equivalents is the only way to get rid of the above-, under- and inside characters. Those characters are encoded in the letters, so they can't be just removed.
I proposed the simple Find-Replace code because for an unknown reason my VBA editor turns diacritics into regular letters so I can't work with them directly. I had to use their Unicodes.

RobiNew · #7 Yesterday, 03:54 AM

I needed code to be inserted in a larger macro. This is the one I eventually adopted (though not complete with regard characters). Thanks again for your help!

' Convert to Unicode Normalization Form D (decomposed form)
Normalized = StrConv(Name, vbUnicode)

Dim Result As String
Result = ""

For i = 1 To Len(Name)
CharCode = AscW(Mid(Name, i, 1))
Select Case CharCode
' Common diacritic replacements
Case 192 To 197: Result = Result & "A"
Case 224 To 229: Result = Result & "a"
Case 200 To 203: Result = Result & "E"
Case 232 To 235: Result = Result & "e"
Case 204 To 207: Result = Result & "I"
Case 236 To 239: Result = Result & "i"
Case 210 To 214, 216: Result = Result & "O"
Case 242 To 246, 248: Result = Result & "o"
Case 217 To 220: Result = Result & "U"
Case 249 To 252: Result = Result & "u"
Case 199: Result = Result & "C"
Case 231: Result = Result & "c"
Case 209: Result = Result & "N"
Case 241: Result = Result & "n"
Case 221: Result = Result & "Y"
Case 253, 255: Result = Result & "y"
Case Else
Result = Result & ChrW(CharCode)
End Select
Next i
Name = Result
' MsgBox Name

vivka · #8 Yesterday, 10:01 AM

RobiNew, good solution! As is Paul's code, in which I replaced diacritics with their codes to fit my VBA.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
VBA Code to remove specific highlight	syl3786	Word VBA	4	03-27-2023 05:01 PM
Sofware or VBA Code to remove Attachments	HowardC	Outlook	7	09-12-2015 05:04 AM
Bug (?) in Arabic & Hebrew diacritics in Word - show red only	vgwilkins	Word	0	01-14-2013 09:09 AM
A crazy spelling grammar - for diacritics	YooNaa Kim	Word	3	01-28-2011 01:39 PM
Diacritics and Word Template	sinojosh	Word	0	03-11-2009 06:58 AM