【VBA】条件が一致したらコピーして別シートに値を貼り付けたい

前提

VBAで任意の日付に異動した社員リストを作成するマクロを作っています。

使用するシートは以下の3枚です。

異動DB
現在の社員名簿
異動者リスト

「異動DB」
イメージ説明

「現在の社員名簿」※氏名、氏名カナは個人情報につき伏せています
イメージ説明

「異動者リスト」
イメージ説明

「現在の社員名簿」と「異動者リスト」の表は全く同じ項目と列幅、フォントの大きさ等に調整しているので、貼り付けは値のみとします。

実現したいこと

ボタンをクリックするとダイアログが開き、任意の日付を入力します。
「OK」をクリックすると、「異動DB」でその日付に異動した社員をオートフィルタで抽出し、「異動者リスト」のA列に該当する社員の社員番号を貼り付けます。
さらに、「現在の社員名簿」のA列と「異動者リスト」のA列が一致した場合のみ、「現在の社員名簿」のＡ列～EN列をコピーして「異動者リスト」に貼り付けを行い、最終行までこれを繰り返すようなコードにしたいです。

該当のソースコード

一部、不要な変数や表現が含まれているかもしれないです。

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 Target_date As Range
11    Dim Target_no As Range
12    Dim i As Long
13    Dim lastRow As Long
14    Dim cnt As Long
15    Dim wS As Worksheet
16    
17
18    flag = False
19    
20    Do While flag = False
21        dval = InputBox("基準日を入力(記入例：1900/1/1)")
22        If StrPtr(dval) = 0 Then
23            'キャンセル又は右上の×をクリックした場合
24            Exit Sub
25        ElseIf dval = "" Then
26            'なにも入力しないでOKをクリックした場合
27            MsgBox ("何も入力されていません")
28        Else
29            '上記以外
30            '入力日付は正しいものとする
31            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
32            d = CDate(dval)
33            flag = True
34        End If
35    Loop
36    
37        '抽出する日付を記入する
38        Worksheets("異動DB").Activate
39        Range("R1") = d
40        
41        'データの書式を「標準」にして日付データをシリアル値にする
42        Range("R1").NumberFormatLocal = "標準"
43        
44        'B列のデータを変数として取得する
45        Set Target_date = Range(Range("B1"), Cells(Rows.Count, 1).End(xlUp))
46   
47        'データの書式を「標準」にしてB列をシリアル値にする
48        Target_date.NumberFormatLocal = "標準"
49        
50        'オートフィルタでセルA1に入力された区分データを抽出する
51        '（抽出する区分は2）
52        Range("A1").AutoFilter Field:=1, Criteria1:="2"
53        
54        'オートフィルタでセルR1に入力された日付で抽出する
55        Range("A1").AutoFilter 2, Range("R1")
56        
57        'データの書式を「日付」に戻す
58        Range("R1").NumberFormatLocal = "yyyy/mm/dd"
59        
60        '抽出した「社員番号」をコピーして貼り付け
61        Range("D1").Offset(1, 0). _
62        Resize(Range("D1").CurrentRegion.Rows.Count - 1).Copy Sheets("異動者リスト").Range("A3")
63        
64        '異動者リストに移動
65        Worksheets("異動者リスト").Activate
66        Set wS = Worksheets("異動者リスト")
67
68        '最終行を取得する
69        lastRow = wS.Cells(Rows.Count, 1).End(xlUp).Row
70
71        '異動者リストに社員情報をコピーする
72        If lastRow > 3 Then
73        Range(wS.Cells(3, "B"), wS.Cells(lastRow, "EN")).ClearContents
74        End If
75        cnt = 2
76        With Worksheets("現在の社員名簿")
77        For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
78        If .Cells(i, "A") = wS.Range("B3") And .Cells(i, "B") = wS.Range("C3") Then
79        cnt = cnt + 1
80        wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value
81        End If
82        Next i
83        End With
84
85        'リストに掛け線を追加する
86        Worksheets("異動者リスト").Range("A2:en" & lastRow).Borders.LineStyle = xlContinuous
87    
88        '先頭にタイトルをつける
89        Worksheets("異動者リスト").Range("A1") = d & "異動者リスト"
90
91     Application.ScreenUpdating = True
92     
93End Sub

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

抽出した「社員番号」を貼り付けるところまでは問題なく動作したのですが、B列から右部分の社員名簿情報が貼りつかない状態です。下記の部分がうまくいかない原因と考えられます。

VBA
1'異動者リストに社員情報をコピーする
2 If lastRow > 3 Then
3        Range(wS.Cells(3, "B"), wS.Cells(lastRow, "EN")).ClearContents
4        End If
5        cnt = 2
6        With Worksheets("現在の社員名簿")
7        For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
8        If .Cells(i, "A") = wS.Range("B3") And .Cells(i, "B") = wS.Range("C3") Then
9        cnt = cnt + 1
10        wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value
11        End If
12        Next i
13        End With

試したこと

下記のURLリンクで参考になりそうなサンプルコードを見つけたので、これをベースとしています。

VBA
1Sub Sample1()
2Dim i As Long, lastRow As Long
3Dim cnt As Long, wS As Worksheet
4Set wS = Worksheets("Sheet2")
5lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
6If lastRow > 3 Then
7Range(wS.Cells(6, "B"), wS.Cells(lastRow, "E")).ClearContents
8End If
9cnt = 5
10With Worksheets("Sheet1")
11For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
12If .Cells(i, "A") = wS.Range("B2") And .Cells(i, "B") = wS.Range("C2") Then
13cnt = cnt + 1
14wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value
15End If
16Next i
17End With
18End Sub

こちらのマクロに合うように数値や変数を書き直したつもりなのですが、社員番号が貼りつくだけで、右の社員情報が貼りつかない状況です。
原因やうまくデータを貼り付ける方法がありましたらご教示いただければと思います。
また、コードも長いため、標準モジュールを追加してコードを分ける等してスリムにする必要があるかと思いますが、ひとまず1つのSub プロシージャで記述していただければ幸いです。
よろしくお願いいたします。

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

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:
・ｖｂａ 2つの条件が一致したらコピーして別シートに値のみ貼り付け
・社員名簿を作る　～その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 Target As Range
11   Dim i As Long
12   Dim cnt As Long
13   Dim LastRow As Long
14   Dim LastClm As Long
15   Dim strDateFormat As String
16   Dim wS1 As Worksheet
17   Dim wS2 As Worksheet
18   Dim wS3 As Worksheet
19    
20   flag = False
21    
22    Do While flag = False
23        dval = InputBox("基準日を入力(記入例：1900/1/1)")
24        If StrPtr(dval) = 0 Then
25            'キャンセル又は右上の×をクリックした場合
26            Exit Sub
27        ElseIf dval = "" Then
28            'なにも入力しないでOKをクリックした場合
29            MsgBox ("何も入力されていません")
30        Else
31            '上記以外
32            '入力日付は正しいものとする
33            '（必要があれば入力日付のチェックを行い、エラーなら再入力する）
34            d = CDate(dval)
35            flag = True
36        End If
37    Loop
38    
39        'ワークシートを変数で宣言
40        Set wS1 = Worksheets("異動DB")
41        Set wS2 = Worksheets("異動者リスト")
42        Set wS3 = Worksheets("現在の社員名簿")
43    
44        '抽出する日付を記入
45        wS1.Activate
46        wS1.Range("R1") = d
47        
48        'B列のデータを変数として取得
49        Set Target = Range(Range("B1"), Cells(Rows.Count, 1).End(xlUp))
50        
51        'オートフィルタでセルA1に入力された区分データを抽出
52        '（抽出する区分は2）
53        Range("A1").AutoFilter Field:=1, Criteria1:="2"
54        
55        'オートフィルタでセルR1に入力された日付で抽出
56        Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
57        
58        '抽出した「社員番号」をコピーして貼り付け
59        Range("D1").Offset(1, 0). _
60        Resize(Range("D1").CurrentRegion.Rows.Count - 1).Copy wS2.Range("A3")
61        
62        '異動者リストに移動
63        wS2.Activate
64
65        '最終行
66        LastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
67        
68        '最終列
69        LastClm = wS2.Cells(2, Columns.Count).End(xlToLeft).Column
70
71        '異動者リストで社員番号より右をクリア
72        If LastRow > 2 Then
73         Range(wS2.Cells(3, "B"), wS2.Cells(LastRow, LastClm)).ClearContents
74        End If
75        
76        '異動者リストに社員情報をコピー
77        With wS3
78         For i = 3 To LastRow
79         For cnt = 3 To LastRow
80          If wS3.Cells(i, "A").Value = wS2.Range(cnt, 1).Value Then
81        
82          wS2.Cells(cnt, 2).Resize(, LastClm -1 ).Value = wS3.Cells(i, 2).Resize(, LastClm -1 ).Value
83        
84          End If
85         Next cnt
86         Next i
87        End With
88
89        'リストに掛け線を追加
90        wS2.Range("A2:en" & LastRow).Borders.LineStyle = xlContinuous
91    
92        '先頭にタイトルをつける
93        wS2.Range("A1") = d & "異動者リスト"
94
95     Application.ScreenUpdating = True
96     
97End Sub

pig_vba

2023/01/13 01:01 編集

参考元はB2:C2に抽出用データが登録されていますが異動者リストにはありません。また、先頭一名しか比較していないことになっている上、社員番号と氏名を比較しているような状態に見えます。正しくは For i = 3 To .Cells(Rows.Count, "A").End(xlUp).Row For cnt = 3 To wS.Cells(Rows.Count, "A").End(xlUp).Row If .Cells(i, "A").value = wS.cells(cnt,1).value Then wS.Cells(cnt,2).Resize(, 4).Value = .Cells(i, 2).Resize(, 4).Value End If next cnt Next i だったりしませんか？

pig_vba

2023/01/13 01:05 編集

また、EN列はcolumns(144)なのでB列.resize(,143)ですが、コード上resize(,4)なのでA-E列までしか情報はいりませんが仕様通りでしょうか？

koburon

2023/01/13 02:59 編集

コメントありがとうございます。 resize(,4)としましたが、最終行のEN列までコピーしたいので誤りです。申し訳ありません。いただいたコメントを踏まえてシート名や最終行の変数等を追記して、コードを編集しました。質問の「追記」の見出しに記載しております。試しに実行したところ、80行目の「社員番号が一致するか」の条件分岐で、エラーが発生してしまいました。 If wS3.Cells(i, "A").Value = wS2.Range(cnt, 1).Value Then 「実行時エラー'1004'; 'Range'メソッドは失敗しました：_'Worksheet’オブジェクト」というエラーメッセージでした。セル値の取得がうまくできていないという意味だとは思いますが、原因はよく分からないですが、解決方法はありますでしょうか。

pig_vba

2023/01/13 02:34 編集

Range型は(row,colmn)指定ができません。 cells(cnt,1)にしてください。ついでですが.resizeプロパティは「そのセルを基準に拡張する」なのでb列からリサイズした場合は1列余分になることに気を付けてください。

koburon

2023/01/13 02:59 編集

コメントありがとうございます。 Range型にしていたのがエラーの原因なのですね。 cellsに変更したところ、エラー表示はなくなりました。また、resize部分も最終行および最終列に-1を追記しましたが、これで144列まで拡張された、という解釈でよろしいでしょうか。コード実行後に「異動者リスト」を確認したのですが、B列から右のセル値がコピーできておらず空欄のままでした。コピーはできても貼り付けが実行されないのか、クリアしてしまったのか何が原因なのか分からない状況です。

pig_vba

2023/01/13 03:07

>また、resize部分も最終行および最終列に-1を追記しましたが、これで144列まで拡張された、という解釈でよろしいでしょうか。はい。あってます。 >列から右のセル値がコピーできておらず空欄のままでした。そもそもIF文を通っていない可能性がありますね…一旦2，3人分くらいにしてデバッグ実行してみてもらえますか。マクロ画面でF8押せば1行ずつ実行することができます。該当部分がちゃんと通過できているか確認してください。

koburon

2023/01/13 04:24

コメントありがとうございます。 >そもそもIF文を通っていない可能性がありますね…一旦2，3人分くらいにしてデバッグ実行してみてもらえますか。 >マクロ画面でF8押せば1行ずつ実行することができます。 80行目にブレークポイントを設定しF8を何度も押して1行ずつ実行してみましたが、エラーは表示されず1行目にセル値は貼りつきませんでした。それ以降押し続けても2行目以降も同様の動きでしたが、これがIF文が通っていない、という意味でしょうか。 IF文である以上Elseが必要なのかな、とも考えたのですが、やはりコードが不足しているのでしょうか。

pig_vba

2023/01/13 04:34

82行目に到達していない、という意味でしたらそもそもIF文が間違っているということになりますね。ただ、コード自体に不備があるようには見えないので80行目到達時点で各セルのvalue値を確認すべきかもしれません。

koburon

2023/01/13 05:19

試しに、IF文にElseを追記してどのように動作するか確認してみました。 If wS3.Cells(i, "A").Value = wS2.Range(cnt, 1).Value Then wS2.Cells(cnt, 2).Resize(, LastClm -1 ).Value = wS3.Cells(i, 2).Resize(, LastClm -1 ).Value Else Msgbox "該当する社員番号がありません" End If F8で1行ずつ実行した際、該当する社員の人数分だけこの動作を繰り返し、それが無くなると次のコードに進むという感じでした。社員番号のセル値が同じように見えているが、実際は一致していないと判断されてしまっている可能性があります。書式が違うだけで一致しないものなのでしょうか。

pig_vba

2023/01/13 05:40

valueは書式設定を無視するはずなのでそれが原因ではないと思います。(書式設定込は.textプロパティが該当します。) ただ、コピーした結果が数値ではなく文字列やシリアル値と認識されている可能性は捨てきれません。一度IF文前で rng1=ws2.cells... rng2=ws3.cells... と変数に格納してみてvalue値が何型になっているか確認してください。原因がこれであればCopy destinationよりCopy pasteSpecialを使うべきという結論になりそうです

koburon

2023/01/13 06:23

IF文前で、以下のコードのようにTypeName関数で、セルの値(Valueプロパティ)を調べてみました。 Dim rng As String rng = rng & TypeName(wS2.Cells(3, 1).Value) & vbCrLf rng = rng & TypeName(wS3.Cells(3, 1).Value) & vbCrLf MsgBox rng 結論から言うと、どちらもDouble型になっていました。型が異なるという理由ではないことはこれでハッキリしましたが、別の原因が分からないです。日付の場合はDouble型ではダメで例えばDate型にしないといけないということでしょうか。

pig_vba

2023/01/13 06:38

あ、それだ。 If CLng(wS3.Cells(i, "A").Value) = CLng(wS2.Cells(cnt, 1).Value) then これ試してください。予想が合ってればこれで行けるはず

koburon

2023/01/13 07:25

いただいたコードに直して実行してみましたが、B列より右に情報が貼りつけられませんでした。いただいたコードはLong型に変換するものだと思いますが、念のためTypeName関数（上のコード）で確認したところ、やはりどちらもDouble型のままでした。原因は別のところにあるのかもしれません。

pig_vba

2023/01/13 08:01

おや？そうでしたか。。。Double型になってるということは浮動小数点誤差が原因だと思ったのですがこの方法だとキャストできませんでしたか…

koburon

2023/01/13 08:58

いろいろと試してみましたが、IF文だけがどうしてもうまくいかない状態ですね。 wS2とｗS3が全く同じ構成のシートで値を貼りつけるだけなので、少し強引かもしれませんが、74行目までの部分で一旦End Subにして、それ以降の処理はvlookup関数などを使ったコードで繰り返し処理して複数列コピペするようにした方が無難かなと思います。

回答1件

自己解決

いろいろと試してみましたが、IF文だけがどうしてもうまくいかない状態で、
社員名簿と全く同じ構成の異動者リストに値を貼りつけるだけなので、
74行目までの部分で一旦End Subにして、社員番号のみ貼りついた状態で終了としました。
それ以降の処理は、異動者リストのB列より右のセルにvlookup関数の数式を入れて、
行数に応じてドラッグして作成するようにします。

=VLOOKUP($A3,現在の社員名簿!$A$3:$EN$2191,B$1,FALSE)

時間がある時にvlookup関数を自動入力するVBAも開発したいと思います。
コメントいただきありがとうございました。

投稿2023/01/16 00:50

koburon

総合スコア22

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

ただいまの回答率
86.02%

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

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

質問する

検索値があった場合は一致した行を転記する

回答4

クリップ1

更新

2022/01/12

Q&A

解決済

【VBA】Sheet1から他のBookのSheet1へCopyする方法がわからないです????

回答3

クリップ0

更新

2019/04/01

Q&A

解決済

VBA 実行時エラー　’1004’ アプリケーション定義またはオブジェクト定義のエラーです

回答3

クリップ1

更新

2017/02/02

Q&A

解決済