前提
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:オートフィルタを操作する
0 コメント