フィルター実行

Sub フィルター実行()
Dim 抽出シート As Worksheet
Dim リストシート As Worksheet
Dim 抽出日付 As Variant
Dim 最終行 As Long
Dim 新しいブック As Workbook
Dim 新しいシート As Worksheet
Dim 保存パス As String

' シートの取得
Set 抽出シート = Worksheets("抽出") ' 抽出シートに変更
Set リストシート = Worksheets("リスト")

' 抽出シートのB1セルから日付を取得
抽出日付 = 抽出シート.Range("B1").Value ' 抽出日付に変更

' 日付が入力されているか確認
If Not IsDate(抽出日付) Then
MsgBox "日付が無効です。"
Exit Sub
End If

' リストシートのB列の最終行を取得
最終行 = リストシート.Cells(Rows.Count, "B").End(xlUp).Row

' フィルター解除
リストシート.AutoFilterMode = False

' フィルターを設定
With リストシート.Range("B1:B" & 最終行)
.AutoFilter Field:=1, Operator:=xlFilterValues, Criteria2:=Array(2, Format(抽出日付, "m/d/yyyy"))
End With

' リストシートをアクティブにする
リストシート.Activate

' 新しいブックにリストシートをコピーして保存
Set 新しいブック = Workbooks.Add
Set 新しいシート = 新しいブック.Sheets(1)

' A列からD列をコピーして書式と値を貼り付け
リストシート.Range("A:D").Copy
新しいシート.Range("A1").PasteSpecial Paste:=xlPasteFormats

' A列からD列をコピーして値だけを貼り付け
リストシート.Range("A:D").Copy
新しいシート.Range("A1").PasteSpecial Paste:=xlPasteValues

' D列からI列をコピーしてそのまま貼り付け
リストシート.Range("E:I").Copy
新しいシート.Range("E1").PasteSpecial xlPasteAll

' 貼り付け後にクリップボードをクリア
Application.CutCopyMode = False

新しいシート.Range("A1").Select

MsgBox "抽出が完了しました"

' ' 保存パスをダウンロードフォルダに設定（適切なフォルダを指定してください）
' 保存パス = Environ("USERPROFILE") & "\Downloads\新しいブック名.xlsx"
'
' ' 新しいブックを保存
' 新しいブック.SaveAs 保存パス ' 保存パスを適切なパスに変更
' 新しいブック.Close SaveChanges:=False
End Sub