グループ:turgenev_ReplaceNonBMPinWord (グリフ実装率：100% [済2、未0])

• Microsoft Wordの置換機能のワイルドカードでは、範囲指定"[○-○]"においてBMP外の文字を使えないようですが、以下のようにUTF16のサロゲート文字をChrW関数によって入力することで一気に置換できることがわかりました。
• [0xD840-0xD8BF][0xDC00-0xDFFF]のように上位サロゲートと下位サロゲートをそれぞれ範囲指定することで、その範囲内の文字同士を組み合わせた文字（この例ならU+20000-U+3FFFF）にヒットします。
• IVSの異体字セレクタ（U+E0100-U+E01EF）も同様の手法で検出できます。
• この方法は英語で調べても見つけられないのでおそらく貴重な情報と思われます。
• また、ベース文字（たとえばu585a）だけで検索・置換をしてもIVS付きの文字（たとえばu585a-ue0102）にはヒットしないようです（BMP内でも外でも同様）。
• 従って、例えば以下のようにすると、IVSが付いたSIP・TIPの文字を花園明朝A、IVSが付いていないSIP・TIPの文字を花園明朝Bにそれぞれ一度に置換できます。
• 以下の例では、CJK統合漢字（拡張含む）・CJK互換漢字（補助含む）・康煕部首・CJK部首補助に属する文字を、IVSやSVSが付いているものも含めて、すべて適切な花園フォントに置換します。
• 少なくともWordにおいては花園明朝を実用しやすくなりそうです。PowerPointやExcelでは置換のシステムが異なるので使えません。
• なお、UndoRecordの部分は本筋とは無関係ですが、このようにStartCustomRecordとEndCustomRecordで囲んでおくとその操作がグループ化され、一度にCtrl+ZやCtrl+Yで戻したりやり直したりできるようになり使いやすくなります。
• また、かなり慎重に指定しないと置換対象に漏れが出てしまうようです。https://gregmaxey.com/word_tip_pages/using_a_macro_to_replace_text_wherever_it_appears_in_a_document.html を参考にしました。

Sub Macro0()
  Set objUndo = Application.UndoRecord
  objUndo.StartCustomRecord ("Replace All with HanaMin")
  'Fix the skipped blank Header/Footer problem.
  lngValidate = ActiveDocument.Sections(1).Headers(1).Range.StoryType
  'Iterate through all story types in the current document.
  Dim rngStory As Range
  For Each rngStory In ActiveDocument.StoryRanges
    'Iterate through all linked stories.
    Do
      SearchAndReplaceInStory rngStory
      On Error Resume Next
      Select Case rngStory.StoryType
        Case 6, 7, 8, 9, 10, 11
          If rngStory.ShapeRange.Count > 0 Then
            For Each oShp In rngStory.ShapeRange
              If oShp.TextFrame.HasText Then
                SearchAndReplaceInStory oShp.TextFrame.TextRange
              End If
            Next
          End If
        Case Else
          'Do Nothing
      End Select
      On Error GoTo 0
      'Get next linked story (if any)
      Set rngStory = rngStory.NextStoryRange
    Loop Until rngStory Is Nothing
  Next
  objUndo.EndCustomRecord
End Sub

Sub SearchAndReplaceInStory(myStoryRange As Range)
    Dim CJK As String
    Dim CJKComp As String
    Dim CJKA As String
    Dim IVS As String
    Dim SVS As String
    Dim CJKBtoF As String
    Dim CJKCompS As String
    Dim TIP As String
    Dim KRadi As String
    Dim RadiSup As String
    CJK = "[" & ChrW(&H4E00) & "-" & ChrW(&H9FFF) & "]"
    CJKComp = "[" & ChrW(&HF900) & "-" & ChrW(&HFAFF) & "]"
    CJKA = "[" & ChrW(&H3400) & "-" & ChrW(&H4DBF) & "]"
    KRadi = "[" & ChrW(&H2F00) & "-" & ChrW(&H2FDF) & "]"
    RadiSup = "[" & ChrW(&H2E80) & "-" & ChrW(&H2EFF) & "]"
    IVS = ChrW(&HDB40) & "[" & ChrW(&HDD00) & "-" & ChrW(&HDDEF) & "]"
    SVS = "[" & ChrW(&HFE00) & "-" & ChrW(&HFE0F) & "]"
    CJKBtoF = "[" & ChrW(&HD840) & "-" & ChrW(&HD87D) & "][" & ChrW(&HDC00) & "-" & ChrW(&HDFFF) & "]"
    CJKCompS = ChrW(&HD87E) & "[" & ChrW(&HDC00) & "-" & ChrW(&HDFFF) & "]"
    TIP = "[" & ChrW(&HD880) & "-" & ChrW(&HD8BF) & "][" & ChrW(&HDC00) & "-" & ChrW(&HDFFF) & "]"
    replaceFont myStoryRange, "花園明朝A", CJK
    replaceFont myStoryRange, "花園明朝A", CJKComp
    replaceFont myStoryRange, "花園明朝A", CJKA
    replaceFont myStoryRange, "花園明朝A", KRadi
    replaceFont myStoryRange, "花園明朝A", RadiSup
    replaceFont myStoryRange, "花園明朝A", CJKCompS
    replaceFont myStoryRange, "花園明朝A", CJK & IVS
    replaceFont myStoryRange, "花園明朝A", CJKA & IVS
    replaceFont myStoryRange, "花園明朝A", CJKBtoF & IVS
    replaceFont myStoryRange, "花園明朝A", TIP & IVS
    replaceFont myStoryRange, "花園明朝A", CJK & SVS
    replaceFont myStoryRange, "花園明朝A", CJKA & SVS
    replaceFont myStoryRange, "花園明朝A", CJKBtoF & SVS
'    replaceFont myStoryRange, "花園明朝A", TIP & SVS
    replaceFont myStoryRange, "花園明朝B", CJKBtoF
    replaceFont myStoryRange, "花園明朝B", TIP
End Sub

Sub replaceFont(myStoryRange As Range, fontName As String, text As String)
    myStoryRange.Find.ClearFormatting
    myStoryRange.Find.Replacement.ClearFormatting
    myStoryRange.Find.Replacement.Font.Name = fontName
    With myStoryRange.Find
        .text = text
        .Replacement.text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
        .Execute Replace:=wdReplaceAll
    End With
End Sub