『複数シートから検索及び抽出』（事務員M）　　 時々参考にさせて頂いております。 [[20121116110548]]　 上記、過去ログと似ていますが、うまく使う事が出来ず 新規に質問させて頂きます 入力11T　・　入力21T　・　入力31R　・　入力41R　という決まった名前のシートが4つあり 見出しも同じでデータを入力して行きます ■入力11T　シート 【A列】 【B列】 【C列】 【D列】 【E列】 【F列】 【G列】 【AD列】【AI列】 5 工場 月 日 番号 商品名 ロット 色合 数量計 合計 6 11T 4 1 152 A 7F 赤 320 4,525 7 11T 4 20 123 B 15F 茶 6,020 10,532 8 11T 5 2 235 C 4B 黒 7,364 30,523 ■入力21T　シート 【A列】 【B列】 【C列】 【D列】 【E列】 【F列】 【G列】 【AD列】【AI列】 5 工場 月 日 番号 商品名 ロット 色合 数量計 合計 6 21T 4 3 223 A 10F 赤 2,330 8,235 7 21T 5 5 251 D 30F 赤 10,230 30,536 8 21T 5 10 238 E 5B 黒 3,000 6,300 A列・E列・AI列はIFを使った関数が入っています。 ■入力31R　シート ■入力41R　シート ■その他集計シート・データベース等があります 各4シートを抽出シートにてA列からG列の間のセルに検索したい数字、文字を 入れ（工場・番号・商品名は入力規則でﾃﾞｰﾀﾍﾞｰｽにて選ぶ）欲しいデータを抽出したい ■抽出シート 【A列】 【B列】 【C列】 【D列】 【E列】 【F列】 【G列】 1 工場 月 日 番号 商品名 ロット 色合 2 A 3 　　【AD列】の数量　【AI列】の数量 4 ↓ 　　↓ 5 工場 月 日 番号 商品名 ロット 色合 数量計 　　合計 6 11T 4 1 152 A 7F 赤 320 　　4,525 7 21T 4 3 223 A 10F 赤 2,330 　　8,235 8 9 各入力シートは合わせると行数がかなりありEXCEL2002では行数をオーバーしてしまいます 質問の足りないところがありましたらすみません どうかよろしくお願いしますm(__)m Excel2002,WindowsXP ---- マクロではないのですが･･･ 抽出シートの AD6セル =SUMIF(INDIRECT("入力"&$A6&"!E$5:E$1000"),$E$2,INDIRECT("入力"&$A6&"!AD$5:AD$1000")) AI6セル =SUMIF(INDIRECT("入力"&$A6&"!E$5:E$1000"),$E$2,INDIRECT("入力"&$A6&"!AI$5:AI$1000")) 下にフィルコピー でも処理が重くなってしまうかな？ (se_9) ---- こんにちは 「EXCEL2002では行数をオーバー」するとしたらどうしようも無いのでは？ 行数オーバーした場合にどうするのか決めないと。 （ウッシ） ---- (se_9)様、ウッシ様　早速のお返事ありがとうございますm(__)m 入力シートそれぞれのシートは行数をオーバーする事はありませんが 集約して検索しようとするとオーバーしてしまいます。 上記の過去ログにありますように、オートフィルターやフィルターオプションで 各シートを回しながら、抽出して検索シートに転記する方法（マクロ）などで出来ればと思っていますが よい方法がありましたら　よろしくお願いします。 ---- こんにちは 各シートの3〜4行目は空白行として、 Sub test() Dim v As Variant Dim k As Range Dim r As Range Set k = Worksheets("抽出").Range("A5:I5") Set r = k.Offset(1) Application.ScreenUpdating = False If k.CurrentRegion.Rows.Count > 1 Then Intersect(k.CurrentRegion, k.Offset(1).Resize(Rows.Count - k.Row)) _ .ClearContents End If r.Value = k.Value For Each v In Array("入力11T", "入力21T", "入力31R", "入力41R") With Worksheets("抽出") Worksheets(v).Range("A5").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range("A1:G2"), _ CopyToRange:=r, _ Unique:=False r.Delete xlShiftUp k.Copy .Range("A5").End(xlDown).Offset(1) Set r = .Range("A5").End(xlDown).Resize(, k.Columns.Count) End With Next r.Delete xlShiftUp Application.ScreenUpdating = True Set k = Nothing Set r = Nothing End Sub （ウッシ） ---- ウッシさん!早速ありがとうございます 頂いてすぐに試しましたが 実行時エラー”1004” 抽出した範囲にはフィールド名がないか、または無効な フィールド名です。 ↓の部分が黄色になっていました。 Worksheets(v).Range("A5").CurrentRegion.AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range("A1:G2"), _ CopyToRange:=r, _ Unique:=False 入力シートの3〜4行目は空白行としてありますが　5行目H列からAC列まで日付、数量と 項目が入っています。 試行錯誤しましたが、どうもエラーが出てしまいます。 ---- こんにちは AE5〜AH5には項目名が入ってないのですか？ （ウッシ） ---- 項目名は入っています。項目下の入力するところは空白もあります。 ここに質問させて頂く前に１シートだけ検索するコードがありましのでそれを使っても 同じエラーが出たため、隠しシートに必要な所だけ転記して検索したところ出来ました。 1シートだけでは目的と違う為どうしても分からず質問させて頂きましたが・・・ お手数かけますm(__)m ---- こんにちは 隠しシート？ 何を言ってるのかわからないんですけど？ 決まった4シートのA5〜AI5には同じ項目名が入っているのが前提です。 項目下の入力するところは空白？ 全くデータの入らない空白行があるのですか？ 1シートだけでは目的と違う？ 4シート処理するコードになっているはずですけど？ （ウッシ） ---- ウッシさん説明が悪くてすみません（汗） ここに質問させて頂く前の事です。 ＞決まった4シートのA5〜AI5には同じ項目名が入っているのが前提です。 はい!　決まった同じ項目です。 ＞全くデータの入らない空白行があるのですか？ はい!　あります。 すみません説明不足でm(__)m ---- こんにちは Sub check() Dim v As Variant Dim r As Range Dim c As Variant For Each v In Array("入力11T", "入力21T", "入力31R", "入力41R") For Each r In Union( _ Worksheets("抽出").Range("A1:G1"), _ Worksheets("抽出").Range("A5:I5")) c = Application.Match(r.Value, Worksheets(v).Range("A5:AI5"), 0) If IsError(c) Then MsgBox r.Address(0, 0) & ":" & r.Value & " 無し：シート名「" & v & "」" End If Next Next End Sub これで、項目名が各シートの項目と一致しているかチェックして下さい。 項目名の相違が無ければ、 Sub test1() Dim v As Variant Dim k As Range Dim r As Range Set k = Worksheets("抽出").Range("A5:I5") Set r = k.Offset(1) Application.ScreenUpdating = False If k.CurrentRegion.Rows.Count > 1 Then Intersect(k.CurrentRegion, k.Offset(1).Resize(Rows.Count - k.Row)) _ .ClearContents End If r.Value = k.Value For Each v In Array("入力11T", "入力21T", "入力31R", "入力41R") With Worksheets("抽出") Intersect(Worksheets(v).UsedRange, _ Worksheets(v).Rows(5).Resize(Rows.Count - 4)) _ .AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range("A1:G2"), _ CopyToRange:=r, _ Unique:=False r.Delete xlShiftUp k.Copy .Range("A5").End(xlDown).Offset(1) Set r = .Range("A5").End(xlDown).Resize(, k.Columns.Count) End With Next r.Delete xlShiftUp Application.ScreenUpdating = True Set k = Nothing Set r = Nothing End Sub こちらを試して下さい。 抽出シート名、入力4シート名は現状に合わせて変更して下さいね。 （ウッシ） ---- ウッシさん!!　出来ました！！ありがとうござますm(__)m 親切丁寧に教えてくださり感謝しています！ ほんとにありがとうございましたm(__)m ---- こんにちは、今頃ですみません(＞＜;) 試した時うまく動き、それから少し間を置いて4月からの入力をようやくすませ実行しましたが 「実行時エラー1004　アプリケーション定義またはオブジェクト定義のエラーです」 がでて、デバッグを押すと k.Copy .Range("A5").End(xlDown).Offset(1) の部分がエラーになっています。 "入力11T"のデータと"入力11T"と同じ商品名があれば"入力21T〜入力51R"のデータは全部表示されますが それ以外"入力21T〜入力51R"にしかない商品名を抽出するとエラー表示されてしまいます。 すみませんがもう一度ご教授お願いできますでしょうか？ よろしくお願いしますm(__)m ---- こんにちは 該当データの無いシートも有るんですね。 Sub test2() Dim v As Variant Dim k As Range Dim r As Range Set k = Worksheets("抽出").Range("A5:I5") Set r = k.Offset(1) Application.ScreenUpdating = False If k.CurrentRegion.Rows.Count > 1 Then Intersect(k.CurrentRegion, k.Offset(1).Resize(Rows.Count - k.Row)) _ .ClearContents End If r.Value = k.Value For Each v In Array("入力11T", "入力21T", "入力31R", "入力41R") With Worksheets("抽出") Intersect(Worksheets(v).UsedRange, _ Worksheets(v).Rows(5).Resize(Rows.Count - 4)) _ .AdvancedFilter _ Action:=xlFilterCopy, _ CriteriaRange:=.Range("A1:G2"), _ CopyToRange:=r, _ Unique:=False r.Delete xlShiftUp If .Range("A5").End(xlDown).Row < Rows.Count Then k.Copy .Range("A5").End(xlDown).Offset(1) Set r = .Range("A5").End(xlDown).Resize(, k.Columns.Count) Else Set r = k.Offset(1) r.Value = k.Value End If End With Next r.Delete xlShiftUp Application.ScreenUpdating = True Set k = Nothing Set r = Nothing End Sub で試して下さい。 （ウッシ） ---- （ウッシ）さん！ありがとうございます！！ スムーズに処理する事が出来ましたm(__)m 気が早く説明不足な私に、何度もご教授頂きありがとうございましたm(__)m