質問をすることでしか得られない、回答やアドバイスがある。

15分調べてもわからないことは、質問しよう!

新規登録して質問してみよう
ただいま回答率
85.48%
VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

Q&A

解決済

1回答

990閲覧

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

koburon

総合スコア29

VBA

VBAはオブジェクト指向プログラミング言語のひとつで、マクロを作成によりExcelなどのOffice業務を自動化することができます。

0グッド

0クリップ

投稿2023/01/23 08:25

編集2023/01/23 08:47

前提

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

  1. 異動DB
  2. 社員マスタ
  3. 異動者リスト

※【異動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:オートフィルタを操作する

気になる質問をクリップする

クリップした質問は、後からいつでもMYページで確認できます。

またクリップした質問に回答があった際、通知やメールを受け取ることができます。

バッドをするには、ログインかつ

こちらの条件を満たす必要があります。

guest

回答1

0

ベストアンサー

いくつか問題点があります。
1.区分のチェックは、1,2,3がOK、以外はNGなので、IsDate関数を使用してはいけません。
IsDateは、文字列が日付として妥当か否かを判定するものです。
地道に、dvalが1か2か3かと比較します。
2.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の部分は文字列でないといけないのですね。事前にもう少し調べるべきでした。勉強不足でした… こちらをベストアンサーとさせていただきます。 ありがとうございました。
guest

あなたの回答

tips

太字

斜体

打ち消し線

見出し

引用テキストの挿入

コードの挿入

リンクの挿入

リストの挿入

番号リストの挿入

表の挿入

水平線の挿入

プレビュー

15分調べてもわからないことは
teratailで質問しよう!

ただいまの回答率
85.48%

質問をまとめることで
思考を整理して素早く解決

テンプレート機能で
簡単に質問をまとめる

質問する

関連した質問