https://qiita.com/Q11Q/items/87dda32e09bcaf5ba067
前回令和元年対応の表示形式を設定するマクロを作りましたが、すでに文字列として入力した日付が日付になることはありません。
正規表現を使って戻します。
選択したセル内に日付らしきものが入っている場合、IsDateで判定してTrueならCdateで変換します
このうちCdateでエラーになるのは小数点で区切る場合のようです。
この場合、正規表現で抜き出してピリオドを書き替えます。
これはExcelのバージョンにもよるかもしれません。
Sub ReiwaDotSeparetedStringDateSerial()
' Microsoft VBscript regular Expression 5.5 参照設定
' 選択したセルの文字列が日付なら日付変換を試みる。
Dim Reg As New RegExp
Dim MC As MatchCollection, M As Match, buf As String, strDate As String
Dim R As Range
For Each R In Selection
If IsDate(R.Value) = False Then
Reg.Global = True
Reg.MultiLine = True
Reg.IgnoreCase = False
Reg.Pattern = "(令和|令|R)([0-9]{1,2}|元)(\.|年|/)[0-9]{1,2}(\.|月|/)[0-9]{1,2}"
Set MC = Reg.Execute(R.Value)
If MC.Count > 0 Then
strDate = MC.Item(0)
End If
If Reg.Test(strDate) Then
buf = Replace(Replace(strDate, ".", "/", 1, -1, vbTextCompare), "元", "01", 1, 1, vbTextCompare):
R.Value = CDate(buf)
Else
Debug.Print "Error : 日付変換できません", R.Address, R.Value
End If
Else
R.Value = CDate(R.Value)
End If
Next
End Sub
RegExp 非参照設定型
参照設定なんて知らないという人はこちらを。
素人用に対応を強化しています。
強化点
全角数字対応
地球上には数字を全角で入れるどうみてもPCを使うなよという人が多いです。全角数字は現在のパターンでは拾えないし、拾う気も全くありません。そのかわりStrConvで対応しました。
日付の文末が空白でも日でも対応
少しわかりにくいと思いますが、この点だけ正規表現を強化しました。これはあとで別の記事にします。
Sub ReiwaDotSeparetedStringDateSerial2()
' 非参照設定型 Microsoft VBscript regular Expression 5.5 参照設定
' 選択したセルの文字列が日付なら日付変換を試みる。
' 全角対応
' 末尾がR元．８．１．のようにピリオド終了も訂正するタイプ
Dim Reg: Set Reg = CreateObject("VBScript.RegExp")
Dim MC 'As MatchCollection
Dim M 'As Match
Dim buf As String, strDate As String
Dim R As Range
With Reg
For Each R In Selection
If IsDate(R.Value) = False Then
.Global = True
.MultiLine = True
.IgnoreCase = False
.Pattern = "(令和|令|R)([0-9]{1,2}|元)(\.|年|/)[0-9]{1,2}(\.|月|/)[0-9]{1,2}($|日|\.)" '($|日|\.)は文末か日かピリオド
Set MC = .Execute(StrConv(R.Value, vbNarrow)) '全角の場合、半角にする
If MC.Count > 0 Then
strDate = MC.Item(0)
End If
If Reg.Test(strDate) Then
buf = Replace(Replace(strDate, ".", "/", 1, -1, vbTextCompare), "元", "01", 1, 1, vbTextCompare)
If Right(buf, 1) = "/" Then buf = Left(buf, Len(buf) - 1) 'ピリオド終了（R02.08.01.とピリオドが末尾になる)だと日付にならないためカット
R.Value = CDate(buf)
Else
Debug.Print "Error : 日付変換できません", R.Address, R.Value
End If
Else
If IsError(CDate(R.Value)) = False Then R.Value = CDate(R.Value)
End If
Next
End With
End Sub