Excel Macro для замены диакритических символов

У меня есть макрос Excel, который, похоже, работает, чтобы заменить некоторые диакритические символы в электронной таблице с ближайшими английскими эквивалентами.

Мне нужно добавить больше к списку диакритических знаков для поиска.

Мне не нужен «авторитетный / полный» список (и замены символов), в идеале просто те, которые обычно используются в основном европейском использовании (умлауты, акценты и т. Д.),

Я надеялся, что у программиста будет список диакритических знаков (или, лучше, код VBA, как и мой, их использование), которые они обычно используют на языке программирования, чтобы дать лучшее решение, чем в приведенном ниже коде.

Sub Replace_Diacritics() With Cells .Replace What:="á", Replacement:="a", MatchCase:=False .Replace What:="é", Replacement:="e", MatchCase:=False .Replace What:="í", Replacement:="i", MatchCase:=False .Replace What:="ó", Replacement:="o", MatchCase:=False .Replace What:="ú", Replacement:="u", MatchCase:=False End With End Sub 

Диапазон кодов символов 192..609 содержит 221 символ, который представляется в ASCII (т.е. может быть преобразован из диакритических символов):

À Á Â Ã Ä Å Æ Ç È É Ê Ë Ì Í Ï Ï Ñ Ñ Ò Ò õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ õ ö ø ù ú û ü ý ý ÿ ÿ Ă Ą Ą Ą Ć Ć Ć Ć Ĉ ĩ Ć Ć Ć Ć Ć ċ ċ ċ ċ ĩ ĩ ĩ ĩ Ğ ĩ ĩ ĩ Ĥ ĩ Ğ ĩ ĩ ĩ ĩ ĩ ĩ ĩ ĩ ĩ ĩ ĩ Ī ī Ĭ ĭ Į į İ İ ı ĵ ĵ ķ Ĺ ĺ ĺ Ļ ļ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ ţ Ť ť Ŧ ŧ Ũ ũ Ū ū ū ŭ ŭ ů Ű ű Ų ų ų ų Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ Ǖ ǖ Ǘ ǘ Ǚ ǚ Ǜ ǜ Ǟ ǟ Ǥ ǥ Ǧ ǧ ǩ Ǫ Ǫ ɡ ɡ ɡ ɡ ɡ

Вы можете попробовать следующую простую функцию, но недостатком является то, что все символы Unicode, которые не представлены в ASCII, будут заменены на ? :

 Function Replace_Diacritics(strText) With CreateObject("ADODB.Stream") .Type = 2 .Mode = 3 .Open .Charset = "ascii" .WriteText strText .Position = 0 Replace_Diacritics = .ReadText .Close End With End Function 

Другая еще одна сложная функция заменяет только символы, которые представляются в ASCII, остальные символы не изменяются:

 Function Replace_Diacritics(strText) Static objDict As Object Dim i, strRange, strCured, strChar, arrRes If objDict Is Nothing Then Set objDict = CreateObject("Scripting.Dictionary") strRange = "" For i = 192 To 609 strRange = strRange & ChrW(i) Next With CreateObject("ADODB.Stream") .Type = 2 .Mode = 3 .Open .Charset = "ascii" .WriteText strRange .Position = 0 strCured = .ReadText .Close End With For i = 192 To 609 strChar = Mid(strCured, i - 191, 1) If strChar <> "?" Then objDict(ChrW(i)) = strChar Next End If arrRes = Array() ReDim arrRes(Len(strText)) For i = 1 To Len(strText) strChar = Mid(strText, i, 1) If objDict.Exists(strChar) Then arrRes(i) = objDict(strChar) Else arrRes(i) = strChar End If Next Replace_Diacritics = Join(arrRes, "") End Function 
Давайте будем гением компьютера.