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

Question

前提

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

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

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

「異動DB」

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

「異動者リスト」

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

実現したいこと

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

該当のソースコード

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

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

    '任意の日の異動者を抽出する
    Application.ScreenUpdating = False
    
    Dim d As Date
    Dim dval As String
    Dim flag As Boolean
    Dim Target_date As Range
    Dim Target_no As Range
    Dim i As Long
    Dim lastRow As Long
    Dim cnt As Long
    Dim wS As Worksheet
    

    flag = False
    
    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
    
        '抽出する日付を記入する
        Worksheets("異動DB").Activate
        Range("R1") = d
        
        'データの書式を「標準」にして日付データをシリアル値にする
        Range("R1").NumberFormatLocal = "標準"
        
        'B列のデータを変数として取得する
        Set Target_date = Range(Range("B1"), Cells(Rows.Count, 1).End(xlUp))
   
        'データの書式を「標準」にしてB列をシリアル値にする
        Target_date.NumberFormatLocal = "標準"
        
        'オートフィルタでセルA1に入力された区分データを抽出する
        '（抽出する区分は2）
        Range("A1").AutoFilter Field:=1, Criteria1:="2"
        
        'オートフィルタでセルR1に入力された日付で抽出する
        Range("A1").AutoFilter 2, Range("R1")
        
        'データの書式を「日付」に戻す
        Range("R1").NumberFormatLocal = "yyyy/mm/dd"
        
        '抽出した「社員番号」をコピーして貼り付け
        Range("D1").Offset(1, 0). _
        Resize(Range("D1").CurrentRegion.Rows.Count - 1).Copy Sheets("異動者リスト").Range("A3")
        
        '異動者リストに移動
        Worksheets("異動者リスト").Activate
        Set wS = Worksheets("異動者リスト")

        '最終行を取得する
        lastRow = wS.Cells(Rows.Count, 1).End(xlUp).Row

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

        'リストに掛け線を追加する
        Worksheets("異動者リスト").Range("A2:en" & lastRow).Borders.LineStyle = xlContinuous
    
        '先頭にタイトルをつける
        Worksheets("異動者リスト").Range("A1") = d & "異動者リスト"

     Application.ScreenUpdating = True
     
End Sub

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

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

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

試したこと

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

Sub Sample1()
Dim i As Long, lastRow As Long
Dim cnt As Long, wS As Worksheet
Set wS = Worksheets("Sheet2")
lastRow = wS.Cells(Rows.Count, "B").End(xlUp).Row
If lastRow > 3 Then
Range(wS.Cells(6, "B"), wS.Cells(lastRow, "E")).ClearContents
End If
cnt = 5
With Worksheets("Sheet1")
For i = 2 To .Cells(Rows.Count, "A").End(xlUp).Row
If .Cells(i, "A") = wS.Range("B2") And .Cells(i, "B") = wS.Range("C2") Then
cnt = cnt + 1
wS.Cells(cnt, "B").Resize(, 4).Value = .Cells(i, "A").Resize(, 4).Value
End If
Next i
End With
End Sub

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

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

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:
・ｖｂａ 2つの条件が一致したらコピーして別シートに値のみ貼り付け
・社員名簿を作る　～その1～

追記

いただいたコメントを参考に、変数などを書き換えてコードを修正しました。

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

    '任意の日の異動者を抽出する
    Application.ScreenUpdating = False
    
    Dim d As Date
    Dim dval As String
    Dim flag As Boolean
   Dim Target As Range
   Dim i As Long
   Dim cnt As Long
   Dim LastRow As Long
   Dim LastClm As Long
   Dim strDateFormat As String
   Dim wS1 As Worksheet
   Dim wS2 As Worksheet
   Dim wS3 As Worksheet
    
   flag = False
    
    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
    
        'ワークシートを変数で宣言
        Set wS1 = Worksheets("異動DB")
        Set wS2 = Worksheets("異動者リスト")
        Set wS3 = Worksheets("現在の社員名簿")
    
        '抽出する日付を記入
        wS1.Activate
        wS1.Range("R1") = d
        
        'B列のデータを変数として取得
        Set Target = Range(Range("B1"), Cells(Rows.Count, 1).End(xlUp))
        
        'オートフィルタでセルA1に入力された区分データを抽出
        '（抽出する区分は2）
        Range("A1").AutoFilter Field:=1, Criteria1:="2"
        
        'オートフィルタでセルR1に入力された日付で抽出
        Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
        
        '抽出した「社員番号」をコピーして貼り付け
        Range("D1").Offset(1, 0). _
        Resize(Range("D1").CurrentRegion.Rows.Count - 1).Copy wS2.Range("A3")
        
        '異動者リストに移動
        wS2.Activate

        '最終行
        LastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
        
        '最終列
        LastClm = wS2.Cells(2, Columns.Count).End(xlToLeft).Column

        '異動者リストで社員番号より右をクリア
        If LastRow > 2 Then
         Range(wS2.Cells(3, "B"), wS2.Cells(LastRow, LastClm)).ClearContents
        End If
        
        '異動者リストに社員情報をコピー
        With wS3
         For i = 3 To LastRow
         For cnt = 3 To LastRow
          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
        
          End If
         Next cnt
         Next i
        End With

        'リストに掛け線を追加
        wS2.Range("A2:en" & LastRow).Borders.LineStyle = xlContinuous
    
        '先頭にタイトルをつける
        wS2.Range("A1") = d & "異動者リスト"

     Application.ScreenUpdating = True
     
End Sub

Comments

[pig_vba]

参考元は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]

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

[koburon]

コメントありがとうございます。
resize(,4)としましたが、最終行のEN列までコピーしたいので誤りです。申し訳ありません。

いただいたコメントを踏まえてシート名や最終行の変数等を追記して、コードを編集しました。
質問の「追記」の見出しに記載しております。
試しに実行したところ、80行目の「社員番号が一致するか」の条件分岐で、エラーが発生してしまいました。

If wS3.Cells(i, "A").Value = wS2.Range(cnt, 1).Value Then

「実行時エラー'1004'; 'Range'メソッドは失敗しました：_'Worksheet’オブジェクト」
というエラーメッセージでした。
セル値の取得がうまくできていないという意味だとは思いますが、原因はよく分からないですが、解決方法はありますでしょうか。

[pig_vba]

Range型は(row,colmn)指定ができません。
cells(cnt,1)にしてください。

ついでですが.resizeプロパティは「そのセルを基準に拡張する」なのでb列からリサイズした場合は1列余分になることに気を付けてください。

[koburon]

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

[pig_vba]

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

[koburon]

コメントありがとうございます。

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

[pig_vba]

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

[koburon]

試しに、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]

valueは書式設定を無視するはずなのでそれが原因ではないと思います。(書式設定込は.textプロパティが該当します。)

ただ、コピーした結果が数値ではなく文字列やシリアル値と認識されている可能性は捨てきれません。

一度IF文前で
rng1=ws2.cells...
rng2=ws3.cells...

と変数に格納してみてvalue値が何型になっているか確認してください。原因がこれであればCopy destinationよりCopy pasteSpecialを使うべきという結論になりそうです

[koburon]

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]

あ、それだ。

If CLng(wS3.Cells(i, "A").Value) = CLng(wS2.Cells(cnt, 1).Value) then

これ試してください。予想が合ってればこれで行けるはず

[koburon]

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

[pig_vba]

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

[koburon]

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

Answer 1

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

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

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