[[20240826174724]]　『複数のテーブルから、データを一つのシートに抽出』（ケント）　ページの最後に飛ぶ

『複数のテーブルから、データを一つのシートに抽出したい。』（ケント）

◯シート1に抽出したデータを表示
◯他シートにあるテーブルの項目としては、名前と日付、内容となります。
　1シートに1人の名前になります。

             A           B         C
1      加藤さん　5/2     早帰り
2     加藤さん　6/2      半日利用

シート1に抽出するとき、日付を指定して該当するデータのみを各シートから抽出する事は可能でしょうか？シート1には、名前は混在する事となります。
VBAもしくは、関数で可能であれば教えて頂きたいです。

＜使用 Excel：Excel2019、使用 OS：Windows11 ＞

 見出し行はないのでしょうか
（マナ） 2024/08/26(月) 19:07:40

すいません、見出し行としては、
A 列に氏名
Ｂ列に日付
Ｃ列に内容　となります。
（ケント） 2024/08/26(月) 19:26:51

 動作確認していませんが、たたき台です。
 実際のデータにあわせて修正してください。
 全くわからないようであれば、Power Quweyの利用をおすすめします。

 Sub test()
    Dim wsExtract As Worksheet
    Dim ws As Worksheet
    Dim tbl As Range
    Dim 指定日 As Long

    Set wsExtract = Worksheets("Sheet1")
    指定日 = wsExtract.Cells(1, 5).Value2
    wsExtract.UsedRange.Offset(1).ClearContents

    For Each ws In Worksheets
        If ws.Name <> wsExtract.Name Then
            Set tbl = ws.Cells(1).CurrentRegion
            tbl.AutoFilter 2, ">=" & 指定日, xlAnd, "<=" & 指定日
            If tbl.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                tbl.Offset(1).Copy wsExtract.Cells(Rows.Count, 1).End(xlUp).Offset(1)
            End If
            tbl.AutoFilter
        End If
    Next

 End Sub
（マナ） 2024/08/26(月) 20:06:53

ありがとうございます。
これは、シート1のE1セルに指定する日付を入力すれば抽出されるという理解でよろしいでしょうか？
（ケント） 2024/08/26(月) 20:23:13

無事作動しました。ありがとうございました。
（ケント） 2024/08/26(月) 20:29:48

　E1セルは入力規則（日付）を設定しておくとよいかもしれません。
（マナ） 2024/08/26(月) 20:40:53

ありがとうございました。
あれからいろいろしてみて以下のコードになりました。
Sub test()

    Dim wsExtract As Worksheet
    Dim ws As Worksheet
    Dim tbl As Range
    Dim 指定日 As Long
    Dim lastRow As Range
    Dim dataStartRow As Long

    ' wsExtractをSheet1に設定
    Set wsExtract = Worksheets("DAY申し送り表")

    ' F1の値を指定日として取得
    指定日 = wsExtract.Cells(1, 6).Value2

    ' データ部分のみをクリア、書式は保持（7行目以降）
    If wsExtract.ListObjects.Count > 0 Then
        With wsExtract.ListObjects(1)
            If Not .DataBodyRange Is Nothing Then
                .DataBodyRange.ClearContents ' テーブル内のデータをクリア
            End If
        End With
    Else
        wsExtract.Rows("7:" & wsExtract.Rows.Count).ClearContents ' 7行目以降をクリア
    End If

    ' 他のワークシートのデータを処理
    For Each ws In Worksheets
        If ws.Name <> wsExtract.Name Then
            ' 現在のワークシートのデータ範囲を取得
            Set tbl = ws.Cells(1).CurrentRegion

            ' 指定日でフィルタリング
            tbl.AutoFilter 2, ">=" & 指定日, xlAnd, "<=" & 指定日

            ' フィルタリングされた行がある場合
            If tbl.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                ' データを貼り付ける開始行を7行目に設定
                dataStartRow = 7

                ' 7行目からの貼り付け範囲を設定
                Set lastRow = wsExtract.Cells(dataStartRow, 1)

                ' フィルタリングされたデータを7行目から貼り付け
                tbl.Offset(1).Resize(tbl.Rows.Count - 1).SpecialCells(xlCellTypeVisible).Copy
                lastRow.PasteSpecial Paste:=xlPasteValues

                ' テーブル範囲の拡張に合わせて貼り付け行を調整
                dataStartRow = dataStartRow + tbl.Columns(1).SpecialCells(xlCellTypeVisible).Count - 1
            End If

            ' フィルター解除
            tbl.AutoFilter
        End If
    Next ws

    ' コピーのハイライトを解除
    Application.CutCopyMode = False
End Sub

現在のコードだと、他ｼｰﾄから抽出するさい２行目からになっているんですが３行目からする際、どのようにすればよいでしょうか？
（ケント） 2024/08/27(火) 13:53:53

 今回も動作確認していませんので、雰囲気だけ。
 使えるところがあるかもしれません。

 Sub test2()
    Dim wsExtract As Worksheet
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim 指定日 As Long

    Set wsExtract = Worksheets("Sheet1")
    指定日 = wsExtract.Cells(1, 6).Value2
    wsExtract.UsedRange.Offset(6).ClearContents

    For Each ws In Worksheets
        If ws.Name <> wsExtract.Name Then
            Set tbl = ws.ListObjects(1)
            tbl.Range.AutoFilter 2, ">=" & 指定日, xlAnd, "<=" & 指定日
            If tbl.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                tbl.DataBodyRange.Copy
                wsExtract.Columns(1).Find("*", , xlValues, , , xlPrevious).Offset(1).PasteSpecial xlPasteValues
            End If
            tbl.Range.AutoFilter
        End If
    Next

 End Sub
（マナ） 2024/08/27(火) 15:57:50

ありがとうございます。ちなみに、上記コードだと抽出されたデータがsheet1で２行目からになるんですが、７行目からの表示にできますか？
（けんと） 2024/08/27(火) 22:23:35

Sub test2()

    Dim wsExtract As Worksheet
    Dim ws As Worksheet
    Dim tbl As ListObject
    Dim 指定日 As Long
    Dim lastRow As Long

    Set wsExtract = Worksheets("Sheet1")
    指定日 = wsExtract.Cells(1, 1).Value2
    wsExtract.UsedRange.Offset(6).ClearContents ' 7行目以降のデータをクリア
    lastRow = 7 ' 最初の貼り付け位置は7行目

    For Each ws In Worksheets
        If ws.Name <> wsExtract.Name Then
            Set tbl = ws.ListObjects(1)
            tbl.Range.AutoFilter 2, ">=" & 指定日, xlAnd, "<=" & 指定日
            If tbl.Range.Columns(1).SpecialCells(xlCellTypeVisible).Count > 1 Then
                tbl.DataBodyRange.Copy
                wsExtract.Cells(lastRow, 1).PasteSpecial xlPasteValues
                lastRow = wsExtract.Cells(wsExtract.Rows.Count, 1).End(xlUp).Row + 1 ' 次の空いている行を更新
            End If
            tbl.Range.AutoFilter
        End If
    Next
End Sub

何とかできました。

ただ、他シートからの抽出がうまくできません。
症状として、３行目の抽出はできますが、４行目の抽出が別の日付だと抽出してくれません。
可能な場合：３行目　４月５日　　・　　　４行目　４月５日
不可の場合；３行目　４月５日　　・　　　４行目　４月１０日
（けんと） 2024/08/27(火) 22:57:34

 > sheet1で２行目からになるんですが、７行目からの表示にできますか？

 6行目には見出しがある前提です。

 > ４行目の抽出が別の日付だと抽出してくれません。

 そんなことはないと思うのですが。
 状況が理解できていません。
 ステップ実行で確認していただけますか。
（マナ） 2024/08/28(水) 07:20:12

 >４行目の抽出が別の日付だと抽出してくれません。

やっていることは、オートフィルターを自動でやっているだけなので、
抽出の指定の仕方を変えればいいと思いますが。。。

 >日付を指定して該当するデータのみを各シートから抽出する

指定した日付を抽出　×

指定した日付以降を抽出　○

最初の質問では読み取れないなぁ。。。。

マクロの記録でコードを取得してみてはいかがでしょうか？
（まっつわん） 2024/08/28(水) 07:49:32

コメント返信：

[ 一覧(最新更新順) ]

[[20240826174724]] 『複数のテーブルから、データを一つのシートに抽出』（ケント） ページの最後に飛ぶ

[[20240826174724]]　『複数のテーブルから、データを一つのシートに抽出』（ケント）　ページの最後に飛ぶ