[[20230204100822]]　『複数のブックからリストにある条件のみを取得』（はるはる）　ページの最後に飛ぶ

『複数のブックからリストにある条件のみを取得』（はるはる）

VBA初心者です。

リストにある条件のみを複数のブックから取得する方法を教えてください。
特定のホルダー（ホルダー名：保存Data)に下記Data sampleのフォーマットのブックが複数保存されています。（ブック名は全てDataxxx)　
　　　
ホルダーにある全てのブックから、抽出リストにあるDataのみを
取得してマクロブック内にある一つのシート(Data1)←にまとめたいのですが、下記の複数ブックからDatを取得するマクロに抽出リストの組み込み方が分からずにおります。
恐縮ですがご教授お願いいたします。
抽出リストはマクロブック内のシートに作成しております。

Sample dataの列がうまく表示されずみずらくて申し訳ございません。

Data sample
Cpty 　　CptyName　 Ccy Type 2023/1/1 2023/1/2　 2023/1/3
TK-ABC 　　TK ABC JPY D 100 200 300
TK-123 　　TK 123　 USD L -200 -300 -400
TK-456 　　TK 456 JPY L -400 -500 -600
TK-789 　　TK 789 GBP D 200 300 400
TK-BCD TK BCD JPY D 300 400 500

抽出リスト
Cpty
TK_ABC
TK_BCD
TK_456

抽出リストが組み込まれていないマクロ

Sub Data()

  Dim A

  'フォルダ内の1つのブック名を取得
  A = Dir(ThisWorkbook.Path & "\保存Data\*")

  Do While A <> ""

    'ブックを開く
    Workbooks.Open ThisWorkbook.Path & "\Data\" & A

    Dim B
    '現在ブックの最終行
    Set B = ThisWorkbook.Sheets("Data1").Cells(Rows.Count, "A").End(xlUp)
    With ActiveWorkbook.Sheets(1).Range("A1").CurrentRegion

      'データ部分を取得
      .Resize(.Rows.Count - 1).Offset(1, 0).Copy B.Offset(1, 1)

      'ブック名を取得
      B.Resize(.Rows.Count - 1).Offset(1, 0) = ActiveWorkbook.Name
    End With

    ActiveWorkbook.Close False 'ブックを閉じる

    A = Dir() '次のブック名を取得

  Loop

End Sub

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

[[20110209184943]]　『[談]シートレイアウトの投稿どうしてますか？』（ｍｏｍｏ）

 レイアウト出力のマクロ使って、
 どのシートに、
 どんなデータがあって、
 実行結果どうなればいいのか
 正確に教えてもらえますか？

 何となく
 ブックを開く
https://vba-labo.rs-techdev.com/archives/1551
 のオートフィルタで複数条件で絞り込む（以下一例）
 .AutoFilter 1, Array("Cpty","TK_ABC","TK_BCD","TK_456"), xlFilterValues

 フィルタ範囲をジャンプ機能の可視セルで選択
 コピーを張り付ける

 という作業をマクロ記録すれば、自力でできそうですよ！！

 ＞Array("Cpty","TK_ABC","TK_BCD","TK_456")
 この部分の作り方がわからないかもしれないので、
 改めて問いかけてくれればどなたか答えてくれると思います。

（稲葉） 2023/02/04(土) 14:28:00

momo様

早速の返信ありがとうございます。
説明不足で申し訳ございませんでした。

Data sample（コピー元）は、.xlmsの拡張子でホルダー名Dataに複数保存されています。実際一つのブックあたりDataは100行ほどあります。
全てのファイルの一行目には　Cpty, CptyName Ccy yyyy/mm/dd の日付が一か月分表示されており、
それぞれの日付の列ごとに金額が記載されています。
Data sample
Cpty 　　CptyName　 Ccy Type 2023/1/1 　2023/1/2　　 2023/1/3
TK-ABC 　　TK ABC 　JPY D 　　100 　　　200 　　　　　　300
TK-123 　　TK 123　 USD L 　　-200 　　-300　　　　　-400
TK-456 　　TK 456 　JPY L 　　-400 　　-500 　　　　　-600
TK-789 　　TK 789 　GBP D 　　　200 　300 　400
TK-BCD 　　TK BCD 　JPY　 D 300 400 500

抽出リストには実際には20から30のCptyコードが存在しておりまして、変更があった場合はこの抽出リストをアップデートすれば抽出条件が更新されるようにしたいのです。
抽出リストはコピー先のマクロが組んであるブックの中に別シートとして存在します。
シート名は　抽出リストです。
Data sampleブックからはCpty,CptyName, Ccy, Type、yyyy/dd/mm（日付は全て）と各列のDataをコピーして、マクロが組み込んである抽出リストシートが存在するブックに取得します。
その場合の条件が、抽出リストに記載のあるCptyだけを取得したいです。

コピー先はData1というシートで、これもマクロが組み込んであるブックです。
実行後の結果は　抽出シートにあるCptyだけが表示されるようにしたいです。
どうぞ宜しくお願い致します。

Cpty 　　CptyName　 Ccy Type 2023/1/1 　2023/1/2　　 2023/1/3
TK-ABC 　　TK ABC 　JPY D 　　100 　　　200 　　　　　　300
TK-456 　　TK 456 　JPY L 　　-400 　　-500 　　　　　　-600
TK-BCD 　　TK BCD　 JPY D 　　　300 　　400　　　　　　 500
（はるはる） 2023/02/04(土) 19:11:09

こんばんわ。＾＾
↑ｍｏｍｏさん、ではなくて、稲葉　様でわ＾＾；
ｍｏｍｏさんのソフトを使って表のアドレスが解るよ～に、されては？
とのご案内だったのでは。(#^^#)
余計なお世話でしたら、お許しを、m(__)m
抽出リストをレンジか配列に取り込んで、ループで全てのリストの要素分
フイルター詳細なんかで取り出しては貼り取り出しては貼とかで。。。。
勿論、配列でメモリーに貯めこんで、一括掃き出しでも可能かと。
でわ
m(__)m
（隠居Z） 2023/02/04(土) 19:45:22

隠居Z様

ご指摘ありがとうございます！初めての投稿で不慣れで
大変失礼しました。

ご提案ありがとうございます。何分まったくの初心者でして
出来ましたら、Sub Data()のマクロのどこにどのような式を記入したらよいか
教えていただくことは可能でしょうか？

（はるはる） 2023/02/04(土) 19:56:48

あ！はい、私なりの方法で宜しければお手伝いさせて戴くのは
良いのですが、何分稲葉先生もご案内の通りセル番地が不確定なので
具体的なコードは想像でしか書けません、そちらでお手直し戴けるなら
サンプルのような物でしたら作らせて戴きます。
少しお時間を戴ければ。。。何分年寄りなもので手が遅く、＾＾；
他の回答者様のアドバイスも引き続きお待ちくださいませ。
m(__)m
（隠居Z） 2023/02/04(土) 20:25:53

隠居Z様

かしこまりました。
どうぞ宜しくお願い致します。

（はるはる） 2023/02/04(土) 20:37:11

＞かしこまりました。
＞どうぞ宜しくお願い致します。
ではないでしょう。
「セル番地が不確定」と指摘されているのだから何故無視するのか。

（NAMAIKI） 2023/02/04(土) 21:15:52

 お話が通じなさそうなので、隠居じーさんさんにお願いして、退散します！
（稲葉） 2023/02/05(日) 07:55:38

NAMAIKI様

そうでした。ご指摘ありがとうございます。

稲葉様、隠居Z様

ご指摘の情報が欠落していまして大変失礼いたしました。
下記の表記で大丈夫でしょうか？
その他必要な情報ございましたらお教えください。
宜しくお願い致します。

Data sample(コピー元）

       B　　　　　C　　  　D     E      F              G              
Row1   Cpty 　　CptyName　 Ccy   Type  2023/1/1　　　 2023/1/2　 　　
Row2  TK-ABC 　　TK ABC 　JPY     D 　　 100 　　　　　　 200　　　　　  
Row3  TK-123 　　TK 123　 USD     L 　　-200             -300           
Row4  TK-456 　　TK 456 　JPY     L　　 -400             -500           
Row5  TK-789 　　TK 789 　GBP     D 　　 300              400

抽出リスト

      A
Row1 Cpty
Row2 TK_ABC
Row3 TK_BCD
Row4 TK_456

実行結果後

        A　　　　　B　　  　C     D      E              F             
Row1   Cpty 　　CptyName　 Ccy   Type  2023/1/1　　　 2023/1/2　 　　
Row2  TK-ABC 　　TK ABC 　JPY     D 　　 100 　　　　　　 200　  
Row3  TK-456 　　TK 456 　JPY     L　　 -400             -500

（はるはる） 2023/02/05(日) 08:00:14

一番最後の投稿を読んでコード作ったんですけど、作ってから一番最初の投稿を読みました。
複数のブックから、ということでしたらパワークエリとかでできそうな気がします。

 Sub test()
     Dim wsData As Worksheet, wsリスト As Worksheet, ws結果 As Worksheet
     Set wsData = Worksheets("Data sample")
     Set wsリスト = Worksheets("抽出リスト")
     Set ws結果 = Worksheets("結果図")
     ws結果.Cells.Clear
     With wsData
         .Range("G1").Resize(.Cells(Rows.Count, 1).End(xlUp).Row).Formula = _
     "=COUNTIF(" & wsリスト.Name & "!" & wsリスト.Range("A1").CurrentRegion.Address & ",A1)"
         .Range("A1").AutoFilter 7, 1
         .Range("A1").CurrentRegion.Resize(, 6).Copy ws結果.Range("A1")
         .Range("G:G").Delete
         .Range("A1").AutoFilter
     End With
 End Sub
（フォーキー） 2023/02/05(日) 08:47:06

おはようございます。
早速ご案内が有った様で。。。m(__)m
当方はやっとテスト環境が整いました。
昼間は何かと予定が御座いまして、。。。(￣▽￣)
夜から制作にかかります。。。間にも
何も合わないかと思いますが。お勉強
の成果発表はお時間がかかりましても
させて頂く予定です。。。←　ほんとかぁ。。。怪しい＾＾；
m(__)m
o,w
コピー元はＢ列から～4項目+月末[1月なら31]まで
だったのですね。＾＾。。。修正修正。(#^^#)ｖ
（隠居Z） 2023/02/05(日) 09:45:03

フォーキー様

ご丁寧にありがとうございます。
説明が不明瞭で申し訳ございませんでした。
パワークエリも選択肢に入るのですね。
ちょっと自信ないですが初めてなのでググってやってみようと思います。

（はるはる） 2023/02/05(日) 12:18:23

隠居Z様

説明不足でご迷惑おかけして申し訳ございませんでした。
何が必要なのかの認識不足でした。
お忙しいところ恐縮ですが、どうぞ宜しくお願い致します。

（はるはる） 2023/02/05(日) 12:21:56

勉強がてらやってみました。正しい（効率がいい）手順なのかわかりませんが・・・

 1 保存DataフォルダにDataxxxファイル（任意の数）とDataリストファイルを格納する
 2 Dataリストファイルには抽出リストシートが存在している。
 3 Dataリストファイルを開き、データタブの「データの取得」「ファイルから」「フォルダから」で保存Dataフォルダを選択する。
 4 「結合」の「結合及び読み込み」を選択して、左下の「エラーのあるファイルをスキップする」にチェックを入れてOKボタンを押す（表示オプションからシートを選択しないと押せないので注意）

    |[A]        |[B]    |[C]     |[D]    |[E]    |[F]    |[G]    
 [1]|Source.Name|Column1|Column2 |Column3|Column4|Column5|Column6
 [2]|Data1.xlsx |Cpty   |CptyName|Ccy    |Type   |  44927|  44928
 [3]|Data1.xlsx |TK-ABC |TK ABC  |JPY    |D      |    100|    200
 [4]|Data1.xlsx |TK-123 |TK 123  |USD    |L      |   -200|   -300
 [5]|Data2.xlsx |Cpty   |CptyName|Ccy    |Type   |  44927|  44928
 [6]|Data2.xlsx |TK-456 |TK 456  |JPY    |L      |   -400|   -500
 [7]|Data2.xlsx |TK-789 |TK 789  |GBP    |D      |    300|    400

 5 読み込んだテーブルの適当なセルを選択すると「クエリ」というタブが出てくるのでそこの「編集」をクリック
 6 Column1を選択し、「行の削除」から「重複の削除」をクリック
 7 1行目を選択し、「1行目をヘッダーとして使用」をクリック
 8 左上の閉じて読み込むをクリック（これをクエリ1とします）

    |[A]   |[B]     |[C]|[D] |[E]       |[F]       
 [1]|Cpty  |CptyName|Ccy|Type|2023/01/01|2023/01/02
 [2]|TK-ABC|TK ABC  |JPY|D   |       100|       200
 [3]|TK-123|TK 123  |USD|L   |      -200|      -300
 [4]|TK-456|TK 456  |JPY|L   |      -400|      -500
 [5]|TK-789|TK 789  |GBP|D   |       300|       400

 9 抽出リストシートを開き、リストの範囲をテーブル化する（挿入タブからテーブル、先頭行を見出し行として使用するにチェック）
 10 データタブの「テーブルまたは範囲から」をクリックして、テーブルをクエリに変換する。
 11 テーブル○○というシートが作成される。（これをクエリ2とする）
 12 最初に作成したクエリ1を選択し、クエリタブの「結合」をクリック
 13 マージエディタ？でクエリを2つ選択できる画面が出てくるので、上をクエリ1（たぶん保存Dataって名前）にし、左端のCpty列を選択
 14 下のクエリはクエリ2（テーブル○○を選択し、同じくCptyを選択
 15 「結合の種類」から「内部（一致する行のみ）」を選択し、OKを押す。
 16 エディタ画面から右端のテーブル○○という列を選択し、「列の削除」をクリック。閉じて読み込む
 17 マージ○○というシートが作成され、一致するデータのみ表示された。

    |[A]   |[B]     |[C]|[D] |[E]       |[F]       
 [1]|Cpty  |CptyName|Ccy|Type|2023/01/01|2023/01/02
 [2]|TK-ABC|TK ABC  |JPY|D   |       100|       200
 [3]|TK-456|TK 456  |JPY|L   |      -400|      -500

 フォルダ内のDataxxファイルを更新したら、保存Dataシートとクエリ1、とマージクエリをそれぞれクエリタブの「更新」を押すことで更新できます。

最初に書きましたが、手順があってるか自信ないです。
最後の更新も、一致する行だけ取り出すならマージクエリだけ更新すればいいんですが、クエリ1は更新されません。
毎回２度更新ボタンを押さなければならないのか・・・と思うと、やはりやり方が違う気がするんですよね・・・

以下参考にしたサイトです。言葉だけじゃわからないと思うので、はるはるさんも参考にしてみてください。
http://officetanaka.net/excel/function/GetAndTransform/04.htm
https://www.y-shinno.com/powerquery-extract-records/
（フォーキー） 2023/02/05(日) 13:48:27

こんばんわ　＾＾
お待たせいたしました｡作ってはみましたが｡何処かでポカッて
るかもしれません(￣▽￣)
参考程度に、お止め下さいませ。m(__)m
各表の情報処理に付きましては､中間の空白行はサポートしておりません｡
エラー処理[異常終了時の別スレのエクセルの後始末等]、便利機能等々
御座いません｡
キー項目のコピー元のハイフンと抽出シートのアンダーバーの相違は
コード中で吸収しています｡
良いのか悪いのか、よくわかりませんが。。。＠＠；
最後に､読込みブック数が多ければ､別途工夫が必要かもしれません｡

365 特有のFILTER関数など使おうかなとは思ったのですが｡
結局、何時ものVBAオンリー[廻しのみのクルクルぱ～コードに
なってしまいました＾＾；]
間違い発見の場合は追記いたしますので、暫く見ていてくださいね。＾＾；
m(__)m、m(__)mm(__)m

 Option Explicit
Sub OneInstanceMain()
    Dim t As Date
    If MsgBox("Data1は初期化されます準備は宜しいですか", vbCritical + vbYesNo) = vbNo Then Exit Sub
    t = Timer
    With Worksheets("Data1")
        .UsedRange.Clear
        .Activate
    End With
    With Application
        .ScreenUpdating = False
        If wSchk And fDchk Then
            dIo
        End If
        .ScreenUpdating = True
        .StatusBar = ""
    End With
    MsgBox "終了" & Format(Int(Timer - t) / 24 / 60 / 60, "hh : mm : ss") & _
                      Format((Timer - t) - Int(Timer - t), ".000") & " 秒"
End Sub
Private Function wSchk() As Boolean
    wSchk = True
    Dim cAry()
    Dim i As Long
    cAry = Array("Data1", "抽出リスト")
    For i = 0 To UBound(cAry)
        If Not Evaluate("=ISREF(" & cAry(i) & "!A1)") Then
            wSchk = False
            Exit For
        End If
    Next
    Erase cAry
End Function
Private Function fDchk() As Boolean
    If Dir(ThisWorkbook.Path & "\Data", vbDirectory) <> "" Then
        fDchk = True
    Else
        fDchk = False
    End If
End Function
Private Sub dIo()
    Dim bNm As String
    Dim nAp As Object
    Dim tWb As Workbook
    Dim pStr As String
    Dim cnt As Long
    Dim kAry() As Variant
    Dim v() As Variant
    Dim i As Long
    Dim lc As Long
    Dim rr As Range
    Dim tws As Worksheet
    pStr = ThisWorkbook.Path & "\Data\*.xlsx"
    bNm = Dir(pStr)
    pStr = ThisWorkbook.Path & "\Data\"
    Set nAp = New Application
    dIo_Sub_kEySet kAry
    Do
        If bNm = "" Then Exit Do
        Set tWb = nAp.Workbooks.Open(pStr & bNm)
        Set tws = tWb.Worksheets(1)
        cnt = cnt + 1
        If cnt = 1 Then
            With Worksheets("Data1")
                With tws
                    lc = .Cells(1, Columns.Count).End(xlToLeft).Column
                    Set rr = .Range(.Cells(1, 2), .Cells(1, lc))
                End With
                .Cells(1).Resize(, rr.Columns.Count) = rr.Value
            End With
        End If
        v = tWb.Sheets(1).Cells(1, 2).CurrentRegion.Value
        dIo_Sub_WsWrite v, kAry
        Erase v
        tWb.Close False
        bNm = Dir()
        Application.StatusBar = Format(cnt, "000000") & "件"
        If cnt Mod 16 = 0 Then DoEvents
    Loop
    nAp.Quit
    Erase kAry, v
End Sub
Private Sub dIo_Sub_kEySet(kAry() As Variant)
    Dim r As Range
    Dim i As Long
    With Worksheets("抽出リスト")
        Set r = .Cells(1).CurrentRegion
        Set r = r.Offset(1).Resize(r.Rows.Count - 1)
        kAry = r.Value
    End With
    For i = LBound(kAry, 1) To UBound(kAry, 1)
        kAry(i, 1) = Replace(kAry(i, 1), "_", "-")
    Next
End Sub
Private Sub dIo_Sub_WsWrite(v, kAry)
    Dim i As Long
    Dim j As Long
    Dim k As Long
    Dim n As Long
    Dim lr As Long
    Dim aAry() As Variant
    Dim w() As Variant
    Dim idx() As Variant
    For i = LBound(kAry) To UBound(kAry)
        For j = 1 To UBound(v, 1)
            If kAry(i, 1) = v(j, 1) Then
                ReDim w(1 To UBound(v, 2))
                For k = 1 To UBound(v, 2)
                    w(k) = v(j, k)
                Next
                ReDim Preserve idx(n)
                idx(n) = w
                n = n + 1
            End If
        Next
    Next
    If n = 0 Then Exit Sub
    ReDim aAry(1 To UBound(idx) + 1, 1 To UBound(idx(0)))
    For i = 0 To UBound(idx)
        For j = 1 To UBound(idx(i))
            aAry(i + 1, j) = idx(i)(j)
        Next
    Next
    With Worksheets("Data1")
        lr = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
        .Cells(lr, 1).Resize(UBound(aAry, 1), UBound(aAry, 2)) = aAry
        .UsedRange.Columns.AutoFit
    End With
    Erase aAry, w, idx
End Sub
（隠居Z） 2023/02/05(日) 22:40:21

すみません。＾＾；
↑まだ、試さないでください早速バグがあるみたいで、修正致
します。今夜は無理っぽいので、今しばらく御猶予を。。。
m(__)m
（隠居Z） 2023/02/05(日) 22:55:58

フォーキー様

初心者にもとても分かりやすくご説明つけていただきまして
誠に感謝いたします。ありがとうございました。
併せて、参照リンクもご紹介いただき参考になります。
ご教授いただいた式で本日やってみます。
もし、わからないことがありましたらまた質問させていただくかもしれません。
何卒宜しくお願い致します。
（はるはる） 2023/02/06(月) 07:47:54

隠居Z様

お忙しい中ご協力いただきまして、誠に感謝いたします。
ありがとうございます！！
初心者の私がやろうとしていること自体ちょっと無理がある構想なのかもしれません。
お手数おかけしておりまして恐縮です。

（はるはる） 2023/02/06(月) 07:53:19

おはようございます。　＾＾
（隠居Z） 2023/02/05(日) 22:40:21
のコードを書き換えいたしました。間違えてるかも。＾＾；
何かの参考にでもなれば幸甚です。
お試の際はバックアップをお忘れなく。。。m(__)m
でわ
（隠居Z） 2023/02/06(月) 08:58:35

 隠居じーさんさんの力作ですねぇ・・・
 時間あったので、元のコードの意図を組みつつ書いてみました。
 元のコードはA列にブック名入れていたと思うので、（はるはる） 2023/02/05(日) 08:00:14の出力結果と違くならないですか？

    Option Explicit
    '
    Sub Data()
        Dim aryFilterList As Variant '抽出リスト
        Dim wb As Workbook    'データをコピーするブック
        Dim myWS As Worksheet 'データを取り込むシート
        Dim fp As String
        Dim myDirectory As String
        Dim tmpLastCell As Range
        Dim CopyRng As Range
        '
        'ファイルが保管されているアドレスを一時保管
        myDirectory = ThisWorkbook.Path & "\保存Data\"
        '
        '抽出リストを一時配列に取り込み
        With ThisWorkbook.Sheets("抽出リスト")
            aryFilterList = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)).Value
            aryFilterList = Application.Transpose(aryFilterList) '★
        End With
        '
        '現在ブックのB列の最終行
        Set myWS = ThisWorkbook.Sheets("Data1")
        Set tmpLastCell = myWS.Cells(Rows.Count, "B") '★B列で最終行を判断する
        '
        'フォルダ内の1つのブック名を取得
        fp = Dir(myDirectory & "*.xls?")
        '
        'ブックを開くループ処理
        Do While fp <> ""
            'ブックを開く
            Set wb = Workbooks.Open(myDirectory & fp)
            'フィルター処理
            With wb.Sheets(1)
                If .AutoFilterMode = True Then .AutoFilterMode = False
            '
                'A列から範囲指定している
                'A列にデータがなければ、Autofilterの範囲に含まれないので、1　そうじゃなければ2
                .Range("A1").CurrentRegion.AutoFilter 1, aryFilterList, xlFilterValues '★

                'タイトルを除くデータのみ変数にセット
                Set CopyRng = Nothing
                Set CopyRng = Intersect(.[a1].CurrentRegion, .[a1].CurrentRegion.Offset(1)) '★
            End With
            '
            'コピー処理
            CopyRng.Copy
            '
            'B列で最終行を判断しているので、A列に戻す
            With tmpLastCell.End(xlUp).Offset(1, -1)
                .PasteSpecial xlValues                                                   'コピーしたフィルタ範囲を貼り付け
                myWS.Range(.Address, tmpLastCell.End(xlUp).Offset(, -1)).Value = wb.Name 'A列にブック名を入れる　★
            End With
            '
            '後始末
            Application.CutCopyMode = False
            Application.DisplayAlerts = False
            ActiveWorkbook.Close False 'ブックを閉じる
            Application.DisplayAlerts = True
            fp = Dir() '次のブック名を取得
        Loop
        MsgBox "データの取得が完了しました"
    End Sub

 ■取り込むフォルダが、Thisworkbook.Pathの「Data」フォルダと「保存Data」フォルダの二つがあったので、「保存Data」に統一しました。

 ■取り込むブックの中身　
 B列からしか提示してもらいませんでしたが、コードはA1.Currentregionでしたので
 A列にデータがないと想定してます。
 　→ある場合は、変更必要です。
    |[A]|[B]   |[C]     |[D]|[E] |[F]     |[G]     
 [1]|   |Cpty  |CptyName|Ccy|Type|2023/1/1|2023/1/2
 [2]|   |TK-ABC|TK ABC  |JPY|D   |     100|     200
 [3]|   |TK-123|TK 123  |USD|L   |    -200|    -300
 [4]|   |TK-456|TK 456  |JPY|L   |    -400|    -500
 [5]|   |TK-789|TK 789  |GBP|D   |     300|     400

 ■抽出リストシート　
 提示してもらったデータは、アンダーバーでしたが、ハイフンでいいんですよね？
    |[A]   
 [1]|Cpty  
 [2]|TK-ABC
 [3]|TK-BCD
 [4]|TK-456

 ■出力結果（Dataシート）　
 提示してもらった結果は、A列が「Cpty」でしたが、コードはブック名でしたので、コードに合わせました。
    |[A]                    |[B]   |[C]     |[D]|[E] |[F]     |[G]     
 [1]|ダミー項目名           |Cpty  |CptyName|Ccy|Type|2023/1/1|2023/1/2
 [2]|Book2 - コピー (2).xlsx|TK-ABC|TK ABC  |JPY|D   |     100|     200
 [3]|Book2 - コピー (2).xlsx|TK-456|TK 456  |JPY|L   |    -400|    -500
 [4]|Book2 - コピー (3).xlsx|TK-ABC|TK ABC  |JPY|D   |     100|     200
 [5]|Book2 - コピー (3).xlsx|TK-456|TK 456  |JPY|L   |    -400|    -500

（稲葉） 2023/02/06(月) 12:40:18

被る部分もありますが、コメントしておきます。

既にパワークエリ案もでているところですが、当初のコードを拝見しますと【無条件で】データを１つのシートに集める方法は理解できているのですよね。
それならば、「実際一つのブックあたりDataは100行」ということで、いくつのブックがあるのかわかりませんが、最終的なデータ総数がそれほどなければ

 (1)とりあえず片っ端からデータを1つのシートにまとめる ←ここはＯＫ
 (2)↑のシートから【フィルタオプション】で【条件に合うデータ】を取り出す

のように処理を分けて考えてみてはどうでしょうか？

    Sub さんぷる()
        Call データ集約処理
        Call データ抽出処理
    End Sub
    '-----------------------------------------------------------------------------------------
    Sub データ集約処理()
        Stop 'ブレークポイントの代わり
        Dim 貼付先セル As Range
        Dim ファイル名 As String
        Dim srcWB As Workbook
        Dim フラグ As Long

        With ThisWorkbook
            On Error Resume Next
            .Worksheets("集約").Delete
            .Worksheets.Add(after:=.Worksheets(.Worksheets.Count)).Name = "集約"
            On Error GoTo 0
            Set 貼付先セル = .Worksheets("集約").Range("B1")
        End With

        ブック名 = Dir(ThisWorkbook.Path & "\保存Data\*")
        Do While ブック名 <> ""
            Set srcWB = Workbooks.Open(ThisWorkbook.Path & "\Data\" & ブック名)

            With srcWB.Sheets(1).Range("B1").CurrentRegion
                .Cells.Offset(フラグ).Copy 貼付先セル
                貼付先セル.Offset(, -1).Resize(.Rows.Count).Value = ブック名
                Set 貼付先セル = 貼付先セル.Offset(.Rows.Count)
            End With
             srcWB.Close False
             フラグ = 1
             ブック名 = Dir()
        Loop
        ThisWorkbook.Worksheets("集約").Range("A1").Value = "由来ブック"
    End Sub
    '-----------------------------------------------------------------------------------------
    Sub データ抽出処理()
        Stop 'ブレークポイントの代わり
        Dim dstSH As Worksheet
        Dim srcSH As Worksheet

        With ThisWorkbook
            Set srcSH = .Worksheets("集約")
            Set dstSH = .Worksheets.Add

            With .Worksheets("抽出リスト")
                srcSH.Range("A1").CurrentRegion.AdvancedFilter _
                Action:=xlFilterCopy, _
                CriteriaRange:=.Range("A1", .Cells(.Rows.Count, "A").End(xlUp)), _
                CopyToRange:=Range("A1"), _
                Unique:=False
            End With
        End With
    End Sub

なお、「2023/02/05(日) 08:00:14」に提示された例だと抽出リストシートが「_（アンダーバー）」になっているので「-（ハイフン）」に直さないと抽出されないとおもいます。（例示の際のタイプミスだと思いますが一応）

（もこな２） 2023/02/06(月) 13:55:50

コメント返信：

[ 一覧(最新更新順) ]

[[20230204100822]] 『複数のブックからリストにある条件のみを取得』（はるはる） ページの最後に飛ぶ

[[20230204100822]]　『複数のブックからリストにある条件のみを取得』（はるはる）　ページの最後に飛ぶ