Всего таких знаков 221 среди основных в диапазоне кодов 192..609:
À Á Â Ã Ä Å Æ Ç È É Ê Ë Ì Í Î Ï Ð Ñ Ò Ó Ô Õ Ö Ø Ù Ú Û Ü Ý à á â ã ä å æ ç è é ê ë ì í î ï ñ ò ó ô õ ö ø ù ú û ü ý ÿ Ā ā Ă ă Ą ą Ć ć Ĉ ĉ Ċ ċ Č č Ď ď Đ đ Ē ē Ĕ ĕ Ė ė Ę ę Ě ě Ĝ ĝ Ğ ğ Ġ ġ Ģ ģ Ĥ ĥ Ħ ħ Ĩ ĩ Ī ī Ĭ ĭ Į į İ ı Ĵ ĵ Ķ ķ Ĺ ĺ Ļ ļ Ľ ľ Ł ł Ń ń Ņ ņ Ň ň Ō ō Ŏ ŏ Ő ő Œ œ Ŕ ŕ Ŗ ŗ Ř ř Ś ś Ŝ ŝ Ş ş Š š Ţ ţ Ť ť Ŧ ŧ Ũ ũ Ū ū Ŭ ŭ Ů ů Ű ű Ų ų Ŵ ŵ Ŷ ŷ Ÿ Ź ź Ż ż Ž ž ƀ Ɖ Ƒ ƒ Ɨ ƚ Ɵ Ơ ơ ƫ Ʈ Ư ư ƶ Ǎ ǎ Ǐ ǐ Ǒ ǒ Ǔ ǔ Ǖ ǖ Ǘ ǘ Ǚ ǚ Ǜ ǜ Ǟ ǟ Ǥ ǥ Ǧ ǧ Ǩ ǩ Ǫ ǫ Ǭ ǭ ǰ ɡ
Можно расширить строки s1 и s2 в представленной выше функции, а я в свое время использовал следующий код:
Option Explicit
Dim oDiaDict
' Инициализация словаря единократно при запуске
Set oDiaDict = GetDiaDict()
' Проверка
MsgBox Replace_Diacritics("ÀÁÂÃÄÅÆÇÈÉÊËÌÍÎÏÐÑÒÓÔÕÖØÙÚÛÜÝàáâãäåæçèéêëìíîïñòóôõöøùúûüýÿĀāĂ㥹ĆćĈĉĊċČčĎďĐđĒēĔĕĖėĘęĚěĜĝĞğĠġĢģĤĥĦħĨĩĪīĬĭĮįİıĴĵĶķĹĺĻļĽľŁłŃńŅņŇňŌōŎŏŐőŒœŔŕŖŗŘřŚśŜŝŞşŠšŢţŤťŦŧŨũŪūŬŭŮůŰűŲųŴŵŶŷŸŹźŻżŽžƀƉƑƒƗƚƟƠơƫƮƯưƶǍǎǏǐǑǒǓǔǕǖǗǘǙǚǛǜǞǟǤǥǦǧǨǩǪǫǬǭǰɡ", oDiaDict)
Function Replace_Diacritics(sText, oDict)
Dim i, sChar, aRes
aRes = Array()
ReDim aRes(Len(sText))
For i = 1 To Len(sText)
sChar = Mid(sText, i, 1)
If oDict.Exists(sChar) Then
aRes(i) = oDict(sChar)
Else
aRes(i) = sChar
End If
Next
Replace_Diacritics = Join(aRes, "")
End Function
Function GetDiaDict()
Dim oDict, i, sRange, sCured, sChar
Set oDict = CreateObject("Scripting.Dictionary")
sRange = ""
For i = 192 To 609
sRange = sRange & ChrW(i)
Next
With CreateObject("ADODB.Stream")
.Type = 2
.Mode = 3
.Open
.Charset = "ascii"
.WriteText sRange
.Position = 0
sCured = .ReadText
.Close
End With
For i = 192 To 609
sChar = Mid(sCured, i - 191, 1)
If sChar <> "?" Then oDict(ChrW(i)) = sChar
Next
Set GetDiaDict = oDict
End Function
Щт Уккщк Куыгьу Туче
’ҐЄгй п Є®¤®ў п бва Ёж : 1251