【VBA】オートフィルタの結果のうち1列分だけ別シートにコピーしたい

Question

前提

VBAで任意の日付に異動した社員リストを出力するマクロを作っています。
使用するブックは1つで、シートは以下の2枚です。

1. 異動DB
2. 異動者リスト

【異動DB】

【異動者リスト】

実現したいこと

以下の流れをくむマクロを作りたいです。
①ボタンをクリックするとフォームが開く
②異動した年月日を入力し、OKをクリックする

③【異動DB】で「A列は"2"」「B列は”入力した年月日”」でオートフィルタ
④絞り込まれたD列（社員番号）の結果をコピー
⑤【異動者リスト】のA列にペーストする

※【異動者リスト】のB列から右の情報は別のマクロで記入するので、今回はA列を埋めるマクロまでとします。

該当のソースコード

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

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

    Dim strDateFormat As String
    Dim wS1 As Worksheet
    Dim wS2 As Worksheet
    
    'ワークシートを変数で宣言する
    Set wS1 = Worksheets("異動DB")
    Set wS2 = Worksheets("異動者リスト")

    flag = False
    strDateFormat = wS1.Range("B2").NumberFormatLocal
    
    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

    '最終行を取得する
    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
        
    'オートフィルタで区分データを抽出する
    '（抽出する区分は2）
    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2"
        
    'オートフィルタで入力した日付を抽出する
    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)
            
    '抽出した社員番号をコピーして貼り付ける
    wS1.Range("D1").CurrentRegion.Copy wS2.Range("A1")
    
    Application.ScreenUpdating = True
     
End Sub

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

上のコードを実行すると、下画像のように【異動DB】の見出しごとペーストされてしまいました。

試したこと

58行目までのオートフィルタは問題なく動作しています。
CurrentRegionプロパティを使用すると、「ひとかたまりのセル範囲全部」を指定してしまうのがコピー失敗の原因と考えています。
下記の参考URLでは「コピー元のセル範囲を、アドレスで決め打ちする方法は無い」と記載されていたのですが、何か別のアプローチで、「社員番号」の1列分のみコピー&ペーストする方法をご教示いただければと思います。よろしくお願いいたします。

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

PC：Windows11
ソフト：Microsoft365 Excel
参考URL:
・絞り込んだ結果をコピーする
・社員名簿を作る　～その1～

Answer 1

以下のようにしてください。

Option Explicit

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

'任意の日の異動者を抽出する
    Application.ScreenUpdating = False

    Dim d As Date
    Dim dval As String
    Dim flag As Boolean
    Dim i As Long
    Dim cnt As Long
    Dim LastRow As Long
    Dim rg As String

    Dim strDateFormat As String
    Dim wS1 As Worksheet
    Dim wS2 As Worksheet

    'ワークシートを変数で宣言する
    Set wS1 = Worksheets("異動DB")
    Set wS2 = Worksheets("異動者リスト")

    flag = False
    strDateFormat = wS1.Range("B2").NumberFormatLocal

    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

    '異動者リストで3行目以降をクリアする
    wS2.Rows("3:" & Rows.Count).ClearContents

    'オートフィルタで区分データを抽出する
    '（抽出する区分は2）
    wS1.Range("A1").AutoFilter Field:=1, Criteria1:="2"

    'オートフィルタで入力した日付を抽出する
    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)

    'オートフィルタ結果の行数をカウントする
    rg = "D1:D" & wS1.Range("D1").CurrentRegion.Rows.Count
    cnt = WorksheetFunction.Subtotal(103, wS1.Range(rg))
    '1行のみの場合（見出し行のみ）終了する
    If cnt = 1 Then Exit Sub

    '抽出した社員番号をコピーして貼り付ける
    LastRow = wS1.Cells(Rows.Count, "D").End(xlUp).Row
    wS1.Range("D1").CurrentRegion.Range("D1").Offset(1, 0).Resize(LastRow - 1, 1).Copy wS2.Range("A3")

    Application.ScreenUpdating = True

End Sub

Comments

[koburon]

回答ありがとうございます。
3行目以降のクリアや抽出結果の行数をカウントするコードは見直していなかったので、参考になりました。
いただいたコードで一部を修正してみます。ありがとうございました。

Answer 2

一番手っ取り早い手法

一列だけですよね？ちょっと見た目悪いですが手っ取り早く行うならこうでいいはずです。

  wS1.Range("D1").CurrentRegion.Copy wS2.Range("A1")
↓
dim rng as range
set rng=  wS1.Range("D1").offset(1,0)'一セル下にずらす
ws1.Range(rng,rng.end(xlDown)).Copy wS2.Range("A1")

手作業で見た時の操作としてはフィルター後にD1セルから一セル下～一番下のセルまで選択してコピーしてるのと同じ操作になります。

別解

cells.specialCellsで可視セルだけ選択することも可能です。

    'オートフィルタで区分データを抽出する

    '（抽出する区分は2）

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

        

    'オートフィルタで入力した日付を抽出する

    wS1.Range("A1").AutoFilter Field:=2, Criteria1:=Format(d, strDateFormat)

            

    '抽出した社員番号をコピーして貼り付ける

    wS1.Range(wS1.Cells(2,4),wS1.Cells(LastRow,4)).specialCells(xlCellTypeVisible).Copy Destination:=wS2.Range("A1")

    

    Application.ScreenUpdating = True

     

End Sub

ただし、こちらの手法はworksheet.ChangeイベントのトリガーになるらしいのでWorksheet.Changeイベントを使用している場合は使えません。

Comments

[koburon]

回答ありがとうございます。
どちらのシートもユーザーがセルに直接文字を入力・削除は行わないことを前提とするので、Worksheet.Changeイベントは使用しないものとし、2番目のコードをさせていただきます。
こちらをベストアンサーとします。
どうもありがとうございました。