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

Question

前提

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

【異動者リスト】

該当のソースコード

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

Sub idou()
'異動者リストを作成する

    '任意の日の異動者を抽出する
    Application.ScreenUpdating = False
    
    Dim d As Date
    Dim dval As String
    Dim flag As Boolean
    Dim i As Long
    Dim cnt As Long
    Dim LastRow As Long
    Dim rg As String
    
    Dim strDateFormat As String
    Dim wS1 As Worksheet
    Dim wS2 As Worksheet
    
    'ワークシートを変数で宣言する
    Set wS1 = Worksheets("異動DB")
    Set wS2 = Worksheets("異動者リスト")

    flag = False
    strDateFormat = wS1.Range("B2").NumberFormatLocal
    
    Do While flag = False
        dval = InputBox("基準日を入力(記入例：1900/1/1)")
        If StrPtr(dval) = 0 Then
            'キャンセル又は右上の×をクリックした場合
            Exit Sub
        ElseIf dval = "" Then
            'なにも入力しないでOKをクリックした場合
            MsgBox ("何も入力されていません")
            
        Else
            '上記以外
            '入力日付は正しいものとする
            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
            d = CDate(dval)
            flag = True
        End If
    Loop

    '異動者リストで3行目以降をクリアする
    wS2.Rows("3:" & Rows.Count).ClearContents
        
    'オートフィルタで区分データを抽出する
    '（抽出する区分は2）
    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2"
        
    'オートフィルタで入力した日付を抽出する
    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
    
    'オートフィルタ結果の行数をカウントする
    rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count
    cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg))
    
    '1行のみの場合（見出し行のみ）終了する
    If cnt = 1 Then Exit Sub
            
    '抽出した社員番号をコピーして貼り付ける
    LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
    wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3")
    
    Application.ScreenUpdating = True
     
End Sub

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

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

実現したいこと

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

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

試したこと

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

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

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

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

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

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

Answer 1

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

Sub idou()
'異動者リストを作成する

    '任意の日の異動者を抽出する
    Application.ScreenUpdating = False
    
    Dim d As Date
    Dim dval As String
    Dim flag As Boolean
    Dim i As Long
    Dim cnt As Long
    Dim LastRow As Long
    Dim rg As String
    
    Dim strDateFormat As String
    Dim wS1 As Worksheet
    Dim wS2 As Worksheet
    
    'ワークシートを変数で宣言する
    Set wS1 = Worksheets("異動DB")
    Set wS2 = Worksheets("異動者リスト")

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

    '異動者リストで3行目以降をクリアする
    wS2.Rows("3:" & Rows.Count).ClearContents
        
    'オートフィルタで区分データを抽出する
    '（抽出する区分は2）
    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2"
        
    'オートフィルタで入力した日付を抽出する
    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
    
    'オートフィルタ結果の行数をカウントする
    rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count
    cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg))
    
    '1行のみの場合（見出し行のみ）終了する
    If cnt = 1 Then
        MsgBox ("該当社員は存在しません")
        Exit Sub
    End If
            
    '抽出した社員番号をコピーして貼り付ける
    LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
    wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3")
    
    Application.ScreenUpdating = True
     
End Sub

Comments

[koburon]

回答ありがとうございます。
あり得ない日付のパターンはElse Ifに組み込むところまでは想像できましたが、
該当しない社員のパターンをどこに組み込むかがよくわかりませんでした。
オートフィルタした結果で判断させればよいという発想ですね。
ベストアンサーとさせていただきます。
ありがとうございました。