【VBA】Inputboxで存在しない日付を入れたらエラーになるように条件分岐させたい

前提

VBAで任意の日に異動した社員のリストを出力するマクロを作っています。
使用するブックは1枚で、シートは以下の2枚です。
【異動DB】
イメージ説明
【異動者リスト】

該当のソースコード

ボタンをクリックするとダイアログが開き、任意の日付(例：2023/1/1)を入力して「OK」をクリックすると、【異動DB】のA列で「2」、B列で「入力した年月日」でオートフィルタされ、抽出された社員番号をコピーして、【異動者リスト】のA列に貼り付けるマクロです。

VBA
1Sub idou()
2'異動者リストを作成する
3
4    '任意の日の異動者を抽出する
5    Application.ScreenUpdating = False
6    
7    Dim d As Date
8    Dim dval As String
9    Dim flag As Boolean
10    Dim i As Long
11    Dim cnt As Long
12    Dim LastRow As Long
13    Dim rg As String
14    
15    Dim strDateFormat As String
16    Dim wS1 As Worksheet
17    Dim wS2 As Worksheet
18    
19    'ワークシートを変数で宣言する
20    Set wS1 = Worksheets("異動DB")
21    Set wS2 = Worksheets("異動者リスト")
22
23    flag = False
24    strDateFormat = wS1.Range("B2").NumberFormatLocal
25    
26    Do While flag = False
27        dval = InputBox("基準日を入力(記入例：1900/1/1)")
28        If StrPtr(dval) = 0 Then
29            'キャンセル又は右上の×をクリックした場合
30            Exit Sub
31        ElseIf dval = "" Then
32            'なにも入力しないでOKをクリックした場合
33            MsgBox ("何も入力されていません")
34            
35        Else
36            '上記以外
37            '入力日付は正しいものとする
38            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
39            d = CDate(dval)
40            flag = True
41        End If
42    Loop
43
44    '異動者リストで3行目以降をクリアする
45    wS2.Rows("3:" & Rows.Count).ClearContents
46        
47    'オートフィルタで区分データを抽出する
48    '（抽出する区分は2）
49    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2"
50        
51    'オートフィルタで入力した日付を抽出する
52    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
53    
54    'オートフィルタ結果の行数をカウントする
55    rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count
56    cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg))
57    
58    '1行のみの場合（見出し行のみ）終了する
59    If cnt = 1 Then Exit Sub
60            
61    '抽出した社員番号をコピーして貼り付ける
62    LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
63    wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3")
64    
65    Application.ScreenUpdating = True
66     
67End Sub

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

ダイアログに何か日付を入力して「OK」をクリックすると、該当する日付が一致すれば【異動者リスト】に値がコピーされますが、該当しない日付やあり得ない日付を入力して「OK」をクリックすると何も起きずに処理が終了します。

実現したいこと

「Do～Loop」の間で、以下の条件の場合、エラーメッセージを表示させるようにコードを追加したいです。

あり得ない日付を入力した場合(「2023/4/31」など)
「区分=2」かつ「入力した日付」で一致する社員がいない場合

試したこと

        ElseIf dval = IsError(d) Then
            'あり得ない日付を入力した場合
            MsgBox ("あり得ない日付です")

下記の参考URLを元にコードを書いてみたのですが、
以下のようにエラーになってしまいました。

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

オートフィルタで一致しない場合のコードも併せて修正する方法をアドバイスいただければ幸いです。
よろしくお願いいたします。

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

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:VBA IsError 関数：エラーかどうかを判定する

回答1件

ベストアンサー

日付がエラーの場合は、日付の再入力に戻ります。
入力日付に該当する社員がいない場合は、エラーメッセージを表示後、処理を終了します。
（入力日付に該当する社員がいない場合も日付の再入力に戻るようにするには、できないことはありませんが、多少コードが汚くなります。）

VBA
1Sub idou()
2'異動者リストを作成する
3
4    '任意の日の異動者を抽出する
5    Application.ScreenUpdating = False
6    
7    Dim d As Date
8    Dim dval As String
9    Dim flag As Boolean
10    Dim i As Long
11    Dim cnt As Long
12    Dim LastRow As Long
13    Dim rg As String
14    
15    Dim strDateFormat As String
16    Dim wS1 As Worksheet
17    Dim wS2 As Worksheet
18    
19    'ワークシートを変数で宣言する
20    Set wS1 = Worksheets("異動DB")
21    Set wS2 = Worksheets("異動者リスト")
22
23    flag = False
24    strDateFormat = wS1.Range("B2").NumberFormatLocal
25    
26    Do While flag = False
27        dval = InputBox("基準日を入力(記入例：1900/1/1)")
28        If StrPtr(dval) = 0 Then
29            'キャンセル又は右上の×をクリックした場合
30            Exit Sub
31        ElseIf dval = "" Then
32            'なにも入力しないでOKをクリックした場合
33            MsgBox ("何も入力されていません")
34            
35        ElseIf IsDate(dval) = False Then
36            '入力日付が正しくない場合
37            MsgBox ("あり得ない日付です")
38        Else
39            '入力日付は正しい場合
40            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
41            d = CDate(dval)
42            flag = True
43        End If
44    Loop
45
46    '異動者リストで3行目以降をクリアする
47    wS2.Rows("3:" & Rows.Count).ClearContents
48        
49    'オートフィルタで区分データを抽出する
50    '（抽出する区分は2）
51    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2"
52        
53    'オートフィルタで入力した日付を抽出する
54    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
55    
56    'オートフィルタ結果の行数をカウントする
57    rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count
58    cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg))
59    
60    '1行のみの場合（見出し行のみ）終了する
61    If cnt = 1 Then
62        MsgBox ("該当社員は存在しません")
63        Exit Sub
64    End If
65            
66    '抽出した社員番号をコピーして貼り付ける
67    LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
68    wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3")
69    
70    Application.ScreenUpdating = True
71     
72End Sub
73