スキルアップ・問題解決なら、モーグにおまかせ！

【田中】
     A B C
2 年月日     人数    天気
3 23/01/03    1    雪
4 23/05/02    1    曇り
5 24/02/03    1    晴れ
6 24/03/05    1    晴れ
7 24/03/25    1    雨
8 24/04/01    1    雨
 
【佐藤】
     A B C
2 年月日    人数    天気
3 24/01/04    2    晴れ
4 24/02/01    1    曇り
5 24/03/25    2    雨
 
【鈴木】
     A B C
2 年月日    人数    天気
3 24/03/01    3    晴れ
4 24/03/26    4    晴れ
5 24/04/01    3    晴れ
 
お世話になります。
このような同じ形式のリストが同一ブックのシートにあります。
これを、別シートの[日別一覧]シートで任意の日にちを指定して抽出したいです。
 
[日別一覧]シート
     A B C D
1 日抽出 24/03/25        
2             
3 氏名     年月日 人数 天気
4 田中     24/03/25 1     雨
5 佐藤     24/03/25 2     雨
 
C1に任意の年月日を入れるとB3以下に抽出結果を上のように出したいです。
 
どなたか教えていただけないでしょうか。
よろしくお願いいたします。
 
※すみません。プレビューすると行列番号がずれてしまいます。
人別のシート内のリストの起点はA2
[日別一覧]シートの抽出結果の起点はB3です。

こんな感じかな？（日別一覧のシートモジュールで）

Sub test()
    Dim ws  As Worksheet
    Dim r As Range
    Dim Cri, rRes As Range, nextRow As Long
    
    Me.UsedRange.Offset(2).ClearContents
    Me.Range("A3:D3") = Array("氏名", "年月日", "人数", "天気")
    Cri = Me.Range("B1").Text
    
    For Each ws In Worksheets
        If ws.Name <> Me.Name Then
            With ws
                Set r = .Range("C2", .Cells(.Rows.Count, "A").End(xlUp))
                r.AutoFilter Field:=1, Criteria1:=Cri
                Set rRes = r.Columns("A").SpecialCells(xlCellTypeVisible)
                
                If rRes.Cells.Count > 1 Then
                    nextRow = Sheets("日別一覧").Cells(.Rows.Count, "B").End(xlUp).Row + 1
                    r.Offset(1).Copy Sheets("日別一覧").Cells(nextRow, "B")
            Sheets("日別一覧").Cells(nextRow, "A").Resize(rRes.Cells.Count - 1) = ws.Name
                End If
                
                .AutoFilterMode = False
            End With
        End If
    Next
End Sub

半平太さん、ありがとうございます。
わたしの送ったのがずれていたので、実行した結果ずれたところに行ってしまい、
一部おかしくなってしまいました。
しかし、抽出結果はばっちりのようです。ありがとうございます。
 
申し訳ありません。自分ではどこの部部を変えたら所定の部分に行くかわかりません。
 
もう一度セルの配置をお伝えしたいです。
 
[人別のシート]
見出しを含むデータの範囲＝A2
 
[日別一覧]シート
 
任意の日を入れるセル＝C1
抽出結果＝B4
※見出しはB3より「氏名」「年月日」「人数」「天気」
 
です。恐れ入ります。よろしくお願いします。
 
 

使い方を覚えて、今のセル配置をもう一度載せさせていただきました。
 
 
 

「佐藤」シート 
     A          B       C
2   年月日	人数	天気
3  24/01/04	2	晴れ
4  24/02/01	1	曇り
5  24/03/25	2	雨
 
[日別一覧]シート
      B          C        D      E
1  日にち抽出	24/03/25		
			
3     氏名	年月日	  人数	 天気

すると、こんな感じかな？

Sub test()
    Dim ws  As Worksheet
    Dim r As Range
    Dim Cri, rRes As Range, nextRow As Long
    
    Intersect(Me.Columns("B:E"), Me.UsedRange.Offset(2)).ClearContents
    Me.Range("B3:E3") = Array("氏名", "年月日", "人数", "天気")
    
    Cri = Me.Range("C1").Text
    
    For Each ws In Worksheets
        If ws.Name <> Me.Name Then
            With ws
                Set r = .Range("C2", .Cells(.Rows.Count, "A").End(xlUp))
                r.AutoFilter Field:=1, Criteria1:=Cri
                Set rRes = r.Columns("A").SpecialCells(xlCellTypeVisible)
                
                If rRes.Cells.Count > 1 Then
                    nextRow = Me.Cells(Me.Rows.Count, "B").End(xlUp).Row + 1
                    r.Offset(1).Copy Me.Cells(nextRow, "C")
                    Me.Cells(nextRow, "B").Resize(rRes.Cells.Count - 1) = ws.Name
                End If
                
                .AutoFilterMode = False
            End With
        End If
    Next
End Sub

半平太さん、ありがとうございます！
このようにしたかったです！
おつきあいくださってありがとうございました！