誰も待っていないでしょうが、未来の自分の為に（最近、色々と忘れっぽくて困るのよ
）
昨日の記事の続きを書いていきたいと思います。
前回は元号の情報を設定したテーブルを準備したところまで終わってましたので、早速ですが変換用のプログラムコードをささっと列挙してしまいます。
まずは、年・月・日をパラメータとして渡すと、和暦文字列に変換するプログラムです。
Public Function YMD2ERA(ByVal y As Integer, ByVal m As Integer, ByVal d As Integer, ByRef rng As Range) As Variant
' 引数を日付型へ変換する
Dim dt As Date
dt = DateSerial(y, m, d)
' 該当する元号を探す
Dim r As Long
For r = 1 To rng.Rows.Count
' 開始年月日の取得
Dim sy As Integer, sm As Integer, sd As Integer
sy = CInt(rng(r, 2))
sm = CInt(rng(r, 3))
sd = CInt(rng(r, 4))
Dim sdt As Date
sdt = DateSerial(sy, sm, sd)
' 終了年月日の取得
Dim ey As Integer, em As Integer, ed As Integer
ey = CInt(rng(r, 5))
em = CInt(rng(r, 6))
ed = CInt(rng(r, 7))
Dim edt As Date
edt = DateSerial(ey, em, ed)
' 引数が開始年月日と終了年月日の間にあるか？
If sdt <= dt And dt <= edt Then
Dim era As String
era = CStr(rng(r, 1))
Dim ry As Integer
ry = y - sy + 1
YMD2ERA = era & CStr(ry) & "年" & CStr(m) & "月" & CStr(d) & "日"
Exit Function
End If
Next
' エラー値を返す。
YMD2ERA = CVErr(xlErrNA)
End Function
次に日付をパラメータとして渡すと、和暦文字列に変換するプログラムです。
1900/1/1 よりも前の日付でも文字列として渡してやれば、IsDate 関数で日付だと認識してくれますので、パラメータの型は Variant としてあります。
IsDate 関数によるチェックを通った場合は、晴れて日付であるということで、そこから年月日の情報を取り出して、先述の YMD2ERA 関数で和暦文字列に変換しております。
Public Function AD2ERA(ByVal dt As Variant, ByRef rng As Range) As Variant
' 日付型ではない場合はエラーを返す
If Not IsDate(dt) Then
AD2ERA = CVErr(xlErrNA)
Exit Function
End If
' 年月日を取得して和暦に変換する
Dim y As Integer, m As Integer, d As Integer
y = Year(dt)
m = Month(dt)
d = Day(dt)
AD2ERA = YMD2ERA(y, m, d, rng)
End Function
最後に和暦から西暦への変換ですが、元号年を取り出す為に文字列の最初の数字の位置を求める必要があります。文字列の中にある最初の数字の位置を返す処理がこの FindFirstNumber 関数となります。
この関数を利用して、和暦から西暦へ変換する関数が ERA2AD 関数となります。
Public Function FindFirstNumber(ByVal str As String) As Long
' パラメータの文字列の文字数 + 1 を初期位置とする
Dim max As Long, ret As Long
max = Len(str) + 1
ret = max
On Error GoTo ERROR_CONTINUE:
' 0 ～ 9 を順番に検索する
Dim i As Long
For i = 0 To 9
' WorksheetFunction.Search 関数で数字の位置を探す。
' 見つからなかった場合はエラーが発生する。
Dim id As Long
id = CLng(WorksheetFunction.Search(CStr(i), str))
' 検出位置の最小値を保持する
ret = IIf(id < ret, id, ret)
GoTo LOOP_CONTINUE
ERROR_CONTINUE:
' この処理がないと、2回目以降のエラー時にキャッチできなくなる
Resume LOOP_CONTINUE
LOOP_CONTINUE:
Next
' 見つからなかった場合は 0 を、そうでない場合は検出位置を返す
FindFirstNumber = IIf(ret = max, 0, ret)
End Function
Public Function ERA2AD(ByVal src As Variant, ByRef rng As Range) As Variant
' 日付型に変換可能？
If IsDate(src) Then
src = AD2ERA(src, rng)
End If
' 最初の数字の位置を検出する。
Dim id As Long
id = FindFirstNumber(src)
If id = 0 Then
' 数字がみつからない場合はエラーを返す。
GoTo ERROR_EXIT
End If
On Error GoTo ERROR_EXIT
' 元号文字列を取得する。
Dim era As String
era = Left(src, id - 1)
' WorksheetFunction.VLookup 関数を使って開始年を取得する。
' 見つからなかった場合はエラーが発生する。
Dim sy
sy = WorksheetFunction.VLookup(era, rng, 2, False)
' "年" で文字列を分割して、元号年が格納されている側から元号を削除する。
Dim arr As Variant
arr = Split(src, "年")
src = Replace(arr(0), era, "")
' 西暦年を取得する。
Dim y As Integer
y = sy + CLng(src) - 1
' 月、日を取得して、西暦年と結合して戻り値とする。
Dim m As Integer, d As Integer
arr = Split(arr(1), "月")
m = CLng(arr(0))
d = CLng(Val(arr(1)))
ERA2AD = CStr(y) & "/" & CStr(m) & "/" & CStr(d)
Exit Function
ERROR_EXIT:
' エラー値を返す。
ERA2AD = CVErr(xlErrNA)
End Function
これらの関数を Module に実装することでワークシート上で変換処理を行うことが出来るようになります。
例えば、ワークシートのA1セルに変換元の日付が入力されているとします。
そういう場合はA1以外のセルに…
=AD2ERA(A1,T_元号設定)
と記述してやることで、和暦に変換された文字列が表示されると思います。
他の関数に関しても同じで…
=ERA2AD(A1,T_元号設定)
こんな感じでOKです。
元号が変わったら、元号テーブルへ新しい元号を追加することで対応できます。
マイクロソフト社も迅速に対応はしてくれますが、それでも少し古めな製品への新元号対応は数カ月掛かりましたし、サポートの終わっている製品だといつまで待っても 平成 のままで 令和 は永久にやってきません（笑）
ましてや、インターネット接続のない環境だとアップデートできません。
そういう場合には今回のように VBA を使って自作することで乗り越えることが出来ることもあったりします。
最初は取っつきにくいかもしれませんが、慣れてくると楽しいですよ！
最後に今回のプログラムを実装済みのサンプルファイルをしばらくの間だけダウンロードできるようにしておきます。
不具合とかあっても宇宙よりも広い心で許してくれる人でしたら、ご自由にお使いください
Googleドライブからダウンロードすると、拡張子が xlsx に勝手に変換されるようですので、xlsm に変更してから EXCEL で起動してください。