【VBA】inputboxを連続して行えるようにしたい

前提

VBAで社員の一覧表から任意の日付に入社・異動および退職した社員を抽出するマクロを作っています。
使用するブックは1つで、シートは以下の3枚です。

異動DB
社員マスタ
異動者リスト

※【異動DB】A列「区分」は以下の数字で区分分けしています。
0:初期状態 1:新規入社 2:異動 3:退職
※【社員マスタ】【異動者リスト】の表は、全く同じ項目と列幅、フォントの大きさに調整しています。

【異動DB】

【社員マスタ】

【異動者リスト】

実現したいこと

以下の流れを実行するコードを作りたいです。

①【異動DB】A列「区分」を最初のインプットボックスに入力
②【異動DB】B列「日付」を2番目のインプットボックスに入力
③入力結果をオートフィルタで抽出
④【異動DB】D列と【社員マスタ】A列を比較して社員番号が一致した時、【社員マスタ】1行分をコピー
⑤コピーした1行分のセル値を【異動者リスト】にペースト
⑥最終行までこれを繰り返す

該当のソースコード

VBA
1Sub taisyoku()
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            
39        Else
40            '入力日付が正しい場合
41            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
42            d = CDate(dval)
43            flag = True
44        End If
45    Loop
46
47    '異動者リストで3行目以降をクリアする
48    wS2.Rows("3:" & Rows.Count).ClearContents
49        
50    'オートフィルタで区分データを抽出する
51    '（抽出する区分は3）
52    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="3"
53        
54    'オートフィルタで入力した日付を抽出する
55    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
56    
57    'オートフィルタ結果の行数をカウントする
58    rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count
59    cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg))
60    
61    '1行のみの場合（見出し行のみ）終了する
62    If cnt = 1 Then
63        MsgBox ("該当する社員が存在しません")
64        
65        'オートフィルタを解除
66        wS1.Range("A1").AutoFilter
67        wS1.Range("B1").AutoFilter
68        
69        Exit Sub
70    End If
71            
72    '抽出した社員番号をコピーして貼り付ける
73    LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
74    wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3")
75    
76    '異動者リストにコピー貼り付け
77    Call Copy
78    
79    Application.ScreenUpdating = True
80     
81End Sub

VBA
1Private Sub Copy()
2    '異動者リストにコピー貼り付け
3    Dim wS1 As Worksheet
4    Dim wS2 As Worksheet
5    Dim lastRow1 As Long
6    Dim lastRow2 As Long
7    Dim row1 As Long
8    Dim row2 As Long
9    Set wS1 = Worksheets("社員マスタ")
10    Set wS2 = Worksheets("異動者リスト")
11    
12    '最終行を取得する
13    lastRow1 = wS1.Cells(Rows.Count, "A").End(xlUp).Row
14    lastRow2 = wS2.Cells(Rows.Count, "A").End(xlUp).Row
15
16    'ループする
17    For row2 = 3 To lastRow2
18        For row1 = 3 To lastRow1
19            If wS2.Cells(row2, 1).Value = wS1.Cells(row1, 1).Value Then
20                wS2.Cells(row2, 2).Resize(, 143).Value = wS1.Cells(row1, 2).Resize(, 143).Value
21                Exit For
22            End If
23        Next
24    Next
25
26End Sub

発生している問題

現状では、上記のSub～End Subを3つ分作成し、52行目の「区分」でオートフィルタを行う部分で、Criteria1の値を「1」「2」「3」に変えることで場合分けしているため、コードが重複して長くなってしまってます。

    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="3"

試したこと

1つのコードにまとめるために、下記URLを参考にして、Criteria1:= の部分で変数（ここでは「sec」）を使用するように書いてみました。

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

ところが、「1」「2」「3」の値を入力しても以下のように、メッセージが表示されてしまいます。

入力し直してください

うまく条件分岐させる方法があれば、ご教示いただけるでしょうか。
よろしくお願いいたします。

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

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:オートフィルタを操作する

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

回答1件

ベストアンサー

いくつか問題点があります。
１．区分のチェックは、1,2,3がOK、以外はNGなので、IsDate関数を使用してはいけません。
IsDateは、文字列が日付として妥当か否かを判定するものです。
地道に、dvalが1か2か3かと比較します。
２．Criteria1:=XXXの部分のxxxは文字列でなければいけません。よって、secをstring型で定義します。
上記を、反映した結果が以下のようになります。

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

投稿2023/01/23 10:57

tatsu99

総合スコア5438

koburon

2023/01/24 00:16

回答ありがとうございます。いただいたコードで実行したところ、区分の入力と日付の入力でそれぞれ正しくインプットボックスが表示され、エラーも回避できました。 IsDate関数については私の確認不足でした。 Criteria1:でXXXの部分は文字列でないといけないのですね。事前にもう少し調べるべきでした。勉強不足でした… こちらをベストアンサーとさせていただきます。ありがとうございました。

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