漢文の訓点【素人Wordマクロ】

Microsoft officeのWordVBAでマクロを組みましたので公開します。
インターネットで検索したり、マクロの記録機能を使ったりしたのを組み合わせだけなので、上手くはないですが、一応動くはずです。
office2021です。
必ず、元データのバックアップを取ってから実行してください。
素人の作ったものなので、信用しすぎないでください。

［内容］

ワード縦書きの文書に対して、実行すると、返り点は下付き文字(縦書きだと左下)、送り仮名は上付き文字(縦書きだと右下)に設定します。
返り点→「れ、一、二、三、四、上、中、下、甲、乙、丙、天、地、人」
送り仮名→全角カタカナ

---

［画像］

元データ

マクロ実行後

---

［注意点］

❶レ点が、カタカナで被るので、元データは「れ」で入力してください。最終的に置換して、下付き文字の「レ」になります。
❷上付き文字と下付き文字は共存できないので、ズレが生じます。
❸一レ点などは、字間をマイナスの値に調整すると見栄えが良くなると思います。
❹単純に、検索して設定するのをループさせているだけなので、量が多いと動作が重いかもしれません。
❺検索しているだけなので、白文に上中下などの文字があっても変えてしまいます。手作業で直してください。

---

［コード］

Sub 訓点()

' SubscriptSelectedText Macro
' Selected text will be changed to subscript
    ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "れ"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "一"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "二"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "三"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "四"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop

        ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "上"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop

    ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "中"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop

    ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "下"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop

     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "甲"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "乙"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "丙"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "天"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "地"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
     ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "人"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Subscript = True
    Loop
    
    
' SuperscriptSelectedText Macro
' Selected text will be changed to superscript
    ActiveDocument.Content.Select
    Selection.Find.ClearFormatting
    With Selection.Find
        .Text = "[ァ-ヾ]"
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
    End With
    Do While Selection.Find.Execute
        Selection.Font.Superscript = True
    Loop
    
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "れ"
        .Replacement.Text = "レ"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchFuzzy = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
End Sub


Sub 下線が引かれた前後に括弧を入れる()

 Dim intCount As Integer
 
 intCount = 0

　　　　　　'25回繰り返す
 For intCount = 1 To 25　
    Selection.Move wdStory, -1
    Selection.Find.ClearFormatting
    Selection.Find.Font.Underline = wdUnderlineSingle
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = True
    End With
     Selection.Find.Execute
     Selection.InsertBefore Text:="("
     Selection.InsertAfter Text:=")"
     Selection.Font.UnderlineColor = wdColorAutomatic
     Selection.Font.Underline = wdUnderlineNone
     Selection.Move wdStory, -1
 Next

End Sub

---

［マクロについて］

ファイルタブ→その他→オプション→ユーザーのリボン設定→開発タブを追加、でマクロが導入できます。検索してください。

---

素人の作ったものなので、信用しすぎないでください。