【VBA】InputBoxで日付を統一した書式で入力できるようにしたい

前提

VBAで任意の日の社員名簿を出力するマクロを作っています。

該当のソースコード

名簿を出力するコードのうち、社員が異動する年月日をインプットボックスで入力し、Sheet1のA2に書き込む部分を示しています。

VBA
1Sub idou()
2    '異動者リストを作成する
3    Dim d As Date
4    Dim dval As String
5    Dim flag1 As Boolean
6    Dim strDateFormat As String
7    Dim wS1 As Worksheet
8
9    Set wS1 = Worksheets("Sheet1")
10    flag1 = False
11    strDateFormat = wS1.Range("B2").NumberFormatLocal
12
13    '異動する年月日を入力する
14    Do While flag1 = False
15        dval = InputBox("基準日を入力してください(記入例：1900/1/1)")
16        If StrPtr(dval) = 0 Then
17            'キャンセル又は右上の×をクリックした場合
18            Exit Sub
19        ElseIf dval = "" Then
20            'なにも入力しないでOKをクリックした場合
21            MsgBox ("何も入力されていません")
22        ElseIf IsDate(dval) = False Then
23            '入力日付が正しくない場合
24            MsgBox ("あり得ない日付です")
25        Else
26            '入力日付が正しい場合
27            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
28            d = CDate(dval)
29            flag1 = True
30        End If
31    Loop
32
33　Range("A2").Value = d
34
35End Sub

実現したいこと

日付の書式を統一したいので、インプットボックスの記入例「1900/1/1」と入力させるようにしたいです。例えば「19000101」等と入力したり、数字が欠けた状態でOKをクリックした場合、「入力し直してください」というメッセージを表示させたいです。

発生している問題・エラーメッセージ

例えばダイアログに「19000101」と数字8桁の文字列を入力して「OK」をクリックすると、以下のエラーメッセージが発生します。

実行時エラー'13:'
型が一致しません。

試したこと

下記の参考URLにある「キャンセル処理入りで日付が入力されるまでインプットボックスを表示し続けるサンプルマクロ」を元に作成したのですが、日付の書式を判別する条件分岐が記載されていません。
「yyyy/mm/dd」という文を書くような気はするのですが、条件分岐についてアドバイスいただければと思います。
よろしくお願いいたします。

補足情報（FW/ツールのバージョンなど）

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:
InputBoxで日付入力チェックを行うには
 社員名簿を作る～その3～

bebebe_

2023/02/14 05:54

365でなくExcel2019で試したところエラーが出なかったので原因がわかりませんが Do While True dval = Application.InputBox("基準日を入力してください(記入例：1900/1/1)") If dval = "" Then 'なにも入力しないでOKをクリックした場合 MsgBox ("何も入力されていません") ElseIf dval = "False" Then 'キャンセル処理 Exit Sub ElseIf IsDate(dval) = False Then '入力日付が正しくない場合 MsgBox ("あり得ない日付です") Else '入力日付が正しい場合 '（必要があれば入力日付のチェックを行い、エラーなら再入力する） d = CDate(dval) Exit Do End If Loop の場合もエラーがでますか？

koburon

2023/02/14 08:35 編集

>bebebe_様コメントありがとうございます。コードを変更し、試しに数字8桁「20230401」を入力したところ「あり得ない日付です」のメッセージが表示されました。数字8桁を入力した場合、自動で「yyyy/mm/dd」の書式に変換するようにコードを追記する必要がありそうです。「2023/4/1」と入力して実行した場合は問題なく実行されました。

tatsu99

2023/02/14 10:46

＞数字8桁を入力した場合、自動で「yyyy/mm/dd」の書式に変換するようにコードを追記する必要がありそうです。入力時のガイドで記入例：1900/1/1と明記しているので、数字８桁の入力時はエラーにして良いと思いますがいかがでしょうか。19000101と入力された時、1900/01/01と自動的に変換してほしいという要望があるのでしょうか。

koburon

2023/02/14 23:55

>tatsu99様コメントありがとうございます。自動変換する要望は特にありませんので、私も数字８桁の入力時にエラーが出る方向が良いと考えています。

tatsu99

2023/02/15 00:06

であれば、数字８桁の入力は、特に対応不要かと思います。（現状で問題なし）但し、2020-12-31、900/1/1、9999/12/31なども正常になります。 /で区切られていないケース /で区切られているが、西暦年の値が、あまりにも小さいか大きいケース等はどのようにされるのでしょうか。このケースも正常として扱うのであれば、現状で問題ないと思います。エラーとして処理したいなら、プログラムを修正すべきです。

koburon

2023/02/15 00:49

確かに、現状のコードでは/区切りや-区切り、あと「年月日」の日本語表記が含まれるパターン等だと、どんな数字であっても処理されてしまいますね。 >/で区切られていないケースこちらについては、Format関数で"####/##/##"の形式に変換するように修正してみます。 >/で区切られているが、西暦年の値が、あまりにも小さいか大きいケースこちらについては、今思いついた方法ですが、入力できる西暦年の範囲を例えば「1900年」から「今年(2023年)の10年後」までとし、その範囲より小さいか大きい値を入力した場合エラー処理する条件を設ければ良いかなと思いますが、実現できそうでしょうか。

tatsu99

2023/02/15 01:33

回答にサンプルを書きました。厳密に細かくチェックはしていませんので、採用する場合は、詳細なテストを行ってください。

行動規範の内容に同意します

回答1件

ベストアンサー

MyCheckDateを呼び出してチェックするようにしました。
戻り値は0（正常）と1（エラー）だけでも良かったのですが、
将来、エラーメッセージを変える場合、役に立つかもしれないので、細かくエラーコードを
わけておきました。
エラーメッセージが”あり得ない日付です”になっていますが、ここは、変えた方が良いかもしれません。
（1899/1/1 とか　2050/12/31 はあり得ない日付ではないので）

Sub idou()
    '異動者リストを作成する
    Dim d As Date
    Dim dval As String
    Dim flag1 As Boolean
    Dim strDateFormat As String
    Dim wS1 As Worksheet

    Set wS1 = Worksheets("Sheet1")
    flag1 = False
    strDateFormat = wS1.Range("B2").NumberFormatLocal

    '異動する年月日を入力する
    Do While flag1 = False
        dval = InputBox("基準日を入力してください(記入例：1900/1/1)")
        If StrPtr(dval) = 0 Then
            'キャンセル又は右上の×をクリックした場合
            Exit Sub
        ElseIf dval = "" Then
            'なにも入力しないでOKをクリックした場合
            MsgBox ("何も入力されていません")
        ElseIf MyCheckDate(dval) <> 0 Then
            '入力日付が正しくない場合
            MsgBox ("あり得ない日付です")
        Else
            '入力日付が正しい場合
            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
            d = CDate(dval)
            flag1 = True
        End If
    Loop

  MsgBox d
End Sub
'日付チェック関数 正常:0 以外：下記参照
'1:日付がyyyy/m/d形式でない
'2:日付が歴上存在しない
'3:日付が1900年未満、又は本年+10年を超えている
Private Function MyCheckDate(ByVal indate As String) As Long
    Dim RE As Object
    Dim wdate As Date
    Set RE = CreateObject("VBScript.RegExp")
    RE.Pattern = "^\d{4}/\d{1,2}/\d{1,2}$"
    RE.Global = True
    MyCheckDate = 1
    If RE.test(indate) = False Then Exit Function
    MyCheckDate = 2
    If IsDate(indate) = False Then Exit Function
    wdate = CDate(indate)
    MyCheckDate = 3
    If Year(wdate) < 1900 Then Exit Function
    If Year(Date) + 10 < Year(wdate) Then Exit Function
    MyCheckDate = 0
End Function

投稿2023/02/15 01:32

tatsu99

総合スコア5458