Results of 1 - 1 of about 8923 for リスト (0.007 sec.)
- [[20230204100822]]
- #score: 2747
- @digest: e9054e00e432ac16ef941927582394bd
- @id: 93429
- @mdate: 2023-02-06T04:55:50Z
- @size: 24712
- @type: text/plain
- #keywords: 出リ (116415), cptyname (95950), cpty (78081), 存da (61986), kary (35786), jpy (29269), tk (25118), data1 (11832), 居z (9387), 先セ (8685), クエ (8548), 付先 (7235), 456 (7054), 2023 (6636), 隠居 (6552), エリ (6077), ク名 (5884), 集約 (5221), data (4889), リス (4298), ブッ (4260), 抽出 (3647), abc (3315), thisworkbook (3202), currentregion (2900), スト (2876), ック (2482), 400 (2318), worksheets (2268), 取得 (2146), 日) (2056), ubound (1938)
- 『複数のブックからリストにある条件のみを取得』（はるはる）
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]] 『[談]シートレイアウトの投稿どうしてますか?』（momo） レイアウト出力のマクロ使って、 どのシートに、 どんなデータがあって、 実行結果どうなればいいのか 正確に教えてもらえますか? 何となく ブックを開く 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 ---- こんばんわ。^^ ↑momoさん、ではなくて、稲葉 様でわ^^; momoさんのソフトを使って表のアドレスが解るよ〜に、されては? とのご案内だったのでは。(#^^#) 余計なお世話でしたら、お許しを、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 コピー元はB列から〜4項目+月末[1月なら31]まで だったのですね。^^。。。修正修正。(#^^#)v （隠居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は更新されません。 毎回2度更新ボタンを押さなければならないのか・・・と思うと、やはりやり方が違う気がするんですよね・・・ 以下参考にしたサイトです。言葉だけじゃわからないと思うので、はるはるさんも参考にしてみてください。 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 ---- 被る部分もありますが、コメントしておきます。 既にパワークエリ案もでているところですが、当初のコードを拝見しますと【無条件で】データを1つのシートに集める方法は理解できているのですよね。 それならば、「実際一つのブックあたりDataは100行」ということで、いくつのブックがあるのかわかりませんが、最終的なデータ総数がそれほどなければ (1)とりあえず片っ端からデータを1つのシートにまとめる ←ここはOK (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」に提示された例だと抽出リストシートが「_（アンダーバー）」になっているので「-（ハイフン）」に直さないと抽出されないとおもいます。（例示の際のタイプミスだと思いますが一応） （もこな2） 2023/02/06(月) 13:55:50... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/202302/20230204100822.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 96997 documents and 607820 words.
訪問者：