[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数シートから検索及び抽出』(事務員M)
時々参考にさせて頂いております。
上記、過去ログと似ていますが、うまく使う事が出来ず
新規に質問させて頂きます
入力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では行数をオーバー」するとしたらどうしようも無いのでは? 行数オーバーした場合にどうするのか決めないと。 (ウッシ)
入力シートそれぞれのシートは行数をオーバーする事はありませんが
集約して検索しようとするとオーバーしてしまいます。
上記の過去ログにありますように、オートフィルターやフィルターオプションで
各シートを回しながら、抽出して検索シートに転記する方法(マクロ)などで出来ればと思っていますが
よい方法がありましたら よろしくお願いします。
こんにちは 各シートの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 (ウッシ)
Worksheets(v).Range("A5").CurrentRegion.AdvancedFilter _
Action:=xlFilterCopy, _ CriteriaRange:=.Range("A1:G2"), _ CopyToRange:=r, _ Unique:=False
入力シートの3〜4行目は空白行としてありますが 5行目H列からAC列まで日付、数量と
項目が入っています。
試行錯誤しましたが、どうもエラーが出てしまいます。
こんにちは
AE5〜AH5には項目名が入ってないのですか? (ウッシ)
お手数かけます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シート名は現状に合わせて変更して下さいね。 (ウッシ)
「実行時エラー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
で試して下さい。 (ウッシ)
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.