Word VBA 半角の西暦日付をFieldCodeと正規表現を使って和暦に変換するマクロ


#Field Codeに自働的に変換できないか
Header / Footer の書式を使うとよいようです。

```vb
Sub SelectDateReplaceAndInsertJapaneseHalfEraField()
'Ver UP
'2019/2/23のような日付を選択していると、選択した文字列から日付を抜き出す(半角/全角混在可能）
'日付になるか判定する
'これをカットする
'半角の元号のフィールドコードの日付に変換する
'令和元年は令和１年で表示される
'
Dim REG: Set REG = CreateObject("VBScript.RegExp")
Dim sPattern As String
Dim oMatches
Dim nbuf As String, buf As String
Dim wRng As Word.Range
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Selection.EndKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[0-9０-９]{4}([\/／])[0-9０-９]{1,2}([\/／])[0-9０-９]{1,2}"
.Forward = False
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
Selection.Find.Execute
Set wRng = Selection.Range
End With
nbuf = Selection.Text
Selection.InsertBefore " " '選択した日付の「前」に半角スペースを入れる。

With REG
  REG.Pattern = "[0-9０-９]{4}([\/／])[0-9０-９]{1,2}([\/／])[0-9０-９]{1,2}"
  REG.Global = True
  REG.MultiLine = False '複数行は考えない
  REG.ignorecase = False
  Set oMatches = .Execute(nbuf)
  If oMatches.Count = 0 Then
    Exit Sub
  Else
    buf = oMatches(0).Value
    If IsDate(buf) = False Then Exit Sub
  End If
End With
Selection.Cut
'Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend
ActiveWindow.View.ShowFieldCodes = True
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldMergeField, Text:= _
"""" & buf & """" & " " & "\@""ggge年M月d日""", PreserveFormatting:=False
GoTo Err_Handle
Exit Sub
Err_Handle:
ActiveWindow.View.ShowFieldCodes = False
Application.ScreenUpdating = True
Application.DisplayAlerts = wdAlertsAll: Debug.Print "Err_Handle OK"
End Sub
```

#実際の使用方法
##文章を打ちます
　今から数十年前、2020/5/1  
##日付を選択します
この文章の日付はわざと日付の後ろに半角スペースが入っています。改行まで含めて選択します。
　今から数十年前、2020/5/1 :leftwards_arrow_with_hook:
　今から数十年前、2016/5/1 :leftwards_arrow_with_hook:
　今から数十年前、令和2年5月1日:leftwards_arrow_with_hook:
後ろの半角スペースは消えましたが、和暦のフィールドコードに換わりました。
文章を打ちながらフィールドコードを入力するのは大変ですし、再利用しなければ日付コンテンツコントロールも重いです。さらに今のWord2013以降には句読点のぶら下がりができないという日本語ワープロとしてもはや死んでいるといってもいいレベルのバグを放置しているので、2010を使わざるを得ません。必然的にこのフィールドコードが必要になります。
https://qiita.com/Q11Q/items/b5748b14c44b613f8d64
以前は変換していました。
#検索と置換はフィールドコードの中身を表示させれば可能
Wordの検索はField Codeの中身を表示しているときは、検索が効きます。このため令和2年５月1日というフィールドコードは「２０２０」では検索できませんが、中身を表示させるとヒットします。つまり、和暦と西暦が混在していても、和暦をフィールドコードで入力すれば、フィールドコードを表示させれば検索ができるということです。さらに置換も可能になります。ただしフィールドを再度表示するときに単なるフィールドの表示、非表示ではなく、フィールドの更新を使うとよいです。たまに変わらないときがあります。もとに戻すときはいいらしいのですが。

#フィールドの更新を手動でするとき
フィールドコードの編集からやると、フィールドコードの一部が消えてしまいます。このため、これを使わず、フィールドの表示　非表示でコードを表示させた方が確実に変換できます。
#追加
##半角変換、ただし、令和元年度は元年度とする

```vb

Sub SelectDateReplaceAndInsertJapaneHalFirstKanjifEraField()
'Ver UP
'2019/2/23のような日付を選択していると、選択した文字列から日付を抜き出す(半角/全角混在可能）
'日付になるか判定する
'これをカットする
'半角の元号のフィールドコードの日付に変換する
'令和元年は令和元年で表示される
'フィールドコードを場合分けする

Dim REG: Set REG = CreateObject("VBScript.RegExp")
Dim sPattern As String
Dim oMatches
Dim nbuf As String, buf As String
Dim wRng As Word.Range
Dim DT As Date
Application.ScreenUpdating = False
Application.DisplayAlerts = wdAlertsNone
Selection.EndKey Unit:=wdStory
Selection.Find.ClearFormatting
With Selection.Find
.Text = "[0-9０-９]{4}([\/／])[0-9０-９]{1,2}([\/／])[0-9０-９]{1,2}"
.Forward = False
.Wrap = wdFindAsk
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchByte = False
.MatchAllWordForms = False
.MatchSoundsLike = False
.MatchFuzzy = False
.MatchWildcards = True
Selection.Find.Execute
Set wRng = Selection.Range
End With
nbuf = Selection.Text
Selection.InsertBefore " " '選択した日付の「前」に半角スペースを入れる。

With REG
  REG.Pattern = "[0-9０-９]{4}([\/／])[0-9０-９]{1,2}([\/／])[0-9０-９]{1,2}"
  REG.Global = True
  REG.MultiLine = False '複数行は考えない
  REG.ignorecase = False
  Set oMatches = .Execute(nbuf)
  If oMatches.Count = 0 Then
    Exit Sub
  Else
    buf = oMatches(0).Value
    If IsDate(buf) = False Then Exit Sub Else DT = CDate(buf)
  End If
End With
Selection.Cut
If DT >= CDate("2019/5/1") And DT < CDate("2020/1/1") Then
ActiveWindow.View.ShowFieldCodes = True
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldMergeField, Text:= _
"""" & buf & """" & " " & "\@""令和元年M月d日""", PreserveFormatting:=False
Else
ActiveWindow.View.ShowFieldCodes = True
Selection.Fields.Add Range:=Selection.Range, Type:=wdFieldMergeField, Text:= _
"""" & buf & """" & " " & "\@""ggge年M月d日""", PreserveFormatting:=False
End If
GoTo Err_Handle
Exit Sub
Err_Handle:
ActiveWindow.View.ShowFieldCodes = False
Application.ScreenUpdating = True
Application.DisplayAlerts = wdAlertsAll: Debug.Print "Err_Handle OK"
End Sub
```