アクセント付きの文字を近い同等の文字で置き換えるExcelマクロ

Question

スプレッドシート内の一部の発音区別文字を最も近い英語に置き換えるように見える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 

Answer 1

チャーコード192..609の範囲はASCIIで表現されている221文字（すなわち、区別符号文字から変換することができる）が含ま：

A A A A A AÆÇÈÉ ÊËÌíÎïÐñòÓÔõöØÙÚûüÝA A A A A AæçèéêëìíîI N〇〇〇〇〇〇ùúûüはいはい A A A A〜C C C C C C C C D DĐ。©EēE E E E取り付けÊ取り付けÊE E G G G G G G G G H H H H 1 I〜I I I I I IİIないしJ J K K L L L L L L L Lのn- N N N N N O〇〇〇〇〇ŒœR R R R R R S S S S S S S S T TŤŤT T U U U 3/4 U U U U U U U U wでする○○○Z、Z、Z、ZŽžɃƉƒƒƗƚƟO OƫƮU U ZǍǎǏǐǑǒǓǔǕǖǗǘǙǚǛǜǞǟǤ ǥǦǧǨǩǫǫǭǭǰɡ

あなたは以下の最も単純な機能を試すことができますが、それは欠点だASCIIで表現できないすべてのUnicode文字は、?に置き換えられますということです。

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 

他のもう1つの複雑な関数は、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