[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『複数シートから抽出方法で?です』(は〜ると)
お世話になります。工程と日程で抽出し、一覧印刷をする為にデータを入力しました。 Sheet1は抽出用シートに使用し、Sheet2〜Sheet9にMAX500行、23列でデータが入力されています。
機種 図番 品名 番号 納期 数量 工程 日程 工程 日程 工程 日程 工程 日程 工程 日程 工程 日程 工程 日程 処理 外注 積込日 で23列です。
工程の列にはリストを使用しており22項目から選択します。
Sheet1のC3にリスト22項目より選択した工程とE3に入力する任意の日程を抽出条件とします。 Sheet2〜9のデータ範囲内すべてを対象にSheet1の6行目からC3、E3両方を満たした行を抽出したいと思っています。
Sheet1のC3に入力される項目はSheet2〜9の7、9、11、13、15、17、19列の内、 いづれかに入力されます。入力されていない場合もあります。
例) 機種 図番 品名 番号 納期 数量 工程 日程 工程 日程 工程 日程 工程 ・・・
○ 1111 aaa h-1 10/26 100 ペガ 10/11 ミクロ 10/12 曲げ 10/15
○ 2222 bbb h-2 10/26 50 ペガ 10/11 曲げ 10/13 処理 10/18
Sheet1のC3に曲げE3に10/13を入力すると上記のような入力をされているSheet2〜9の 500行23列の中から条件を満たす行すべてをSheet1の6行目以降に抽出する方法を考えています。
しかし、エクセルの修行が足りずこちらに辿り着きました。 LOOKUP系関数ではなくindexを使うのが近そうでしたが、思ったように抽出出来ません。 関数以外でも構いませんので、御教授頂けませんでしょうか。 宜しくお願い致します。 長文申し訳御座いません。
OS win2k Excel2000 環境
処理方法は、マクロでの処理としてみましたが、 以下のことを手作業で行なっても 可能だと思います。 Sheet2〜Sheet9の項目を工程1,日程1〜工程7、日程7に変更します。 Sheet2〜Sheet9のデータをSheet10へコピーします。(作業シートとして使用します) Sheet10の1行目には項目行をコピーします。 Sheet1にフィルタオプションの設定でデータを抽出します。 Sheet1のF2セルに抽出条件を入力します。(非常に長いです) =OR(AND(Sheet10!G2=Sheet1!C3,Sheet1!E3=Sheet10!H2), AND(Sheet1!C3=Sheet10!I2,Sheet1!E3=Sheet10!J2),AND(Sheet10!K2=Sheet1!C3,Sheet1!E3=Sheet10!L2), AND(Sheet1!C3=Sheet10!M2,Sheet1!E3=Sheet10!N2),AND(Sheet10!O2=Sheet1!C3,Sheet1!E3=Sheet10!P2), AND(Sheet1!C3=Sheet10!Q2,Sheet1!E3=Sheet10!R2),AND(Sheet10!S2=Sheet1!C3,Sheet1!E3=Sheet10!T2)) (この数式をVBAでどう書けばいいか判らなかったので、シートに書き込みました) サンプルをUpしておきます。tyusyutu.xls(約250KB) http://www.geocities.jp/hatch4700/index.html データ量は各シート50件計400件のデータとしています。 (各シート500件だと2MB以上と大きくなったためです) マクロは詳しくないのでフォローは期待しないでください。 このような方法があるということで・・・(Hatch)
今、気づいたのですが、データをコピーして貼り付けたらデータ量が倍になり ファイル容量がかなり肥大するのでちょっとヤバイかも・・・ 他の方法に期待された方がいいかも・・・(Hatch)
Hatch様 ありがとうございます。 データ量は気にしています。 データファイルとコピー用ファイルと 抽出ファイルの3ファイルに分けた方が宜しいでしょうか? サンプルファイルをさわってみます。
Sheet2〜9のデータをSheet10にコピーしてから、フィルタオプションを使っていますが、 各シートごとにフィルタオプションで抽出してやれば良さそうです。 ただ、私にはこのコードを書くスキルが無いので・・・ # VBAで各シートまたはSheet1にまとめた条件式の書き方が分らない (>_<)
ファイルの分割に関してはファイル管理がめんどくさそうな気もしますが、 どうなんでしょうか? 識者各位のご意見をお待ちください・・・m(_ _)m (Hatch)
マクロを書き直して、Sheet10へのコピーをしないようにしました。 ↓へUpしています。 http://www.geocities.jp/hatch4700/index.html しかし、条件式がとてつもなく長い・・・(^_^;) (Hatch) Sub test02() Dim i As Long Dim lastRow As Long, wsRow As Long Application.ScreenUpdating = False ' Sheet1のA6以降を削除 lastRow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row If lastRow >= 6 Then Range("A6:W" & lastRow).Delete shift:=xlShiftUp End If ' 条件式をF3にSheet2用の数式を入力 Worksheets("Sheet1").Range("F3").Formula = "=OR(AND(Sheet2!G2=Sheet1!C3,Sheet1!E3=Sheet2!H2),AND(Sheet1!C3=Sheet2!I2,Sheet1!E3=Sheet2!J2),AND(Sheet2!K2=Sheet1!C3,Sheet1!E3=Sheet2!L2),AND(Sheet1!C3=Sheet2!M2,Sheet1!E3=Sheet2!N2),AND(Sheet2!O2=Sheet1!C3,Sheet1!E3=Sheet2!P2),AND(Sheet1!C3=Sheet2!Q2,Sheet1!E3=Sheet2!R2),AND(Sheet2!S2=Sheet1!C3,Sheet1!E3=Sheet2!T2))" 'フィルタオプションの設定でデータ抽出 For i = 2 To 9 ' Sheet3以降の条件式(シート名を入れ替えています) If i >= 3 Then Worksheets("Sheet1").Range("F3").Replace "Sheet" & i - 1, "Sheet" & i End If ' データシートの最終行を取得 lastRow = Worksheets("Sheet" & i).Range("A65536").End(xlUp).Row ' Sheet2の時、Sheet1の抽出先を6行目をwsRowに入れる If i = 2 Then wsRow = 6 Else ' Sheet1の最終行をwsRowに入れる wsRow = Worksheets("Sheet1").Range("A65536").End(xlUp).Row + 1 End If ' フィルタオプションの設定 Worksheets("Sheet" & i).Range("A1:W" & lastRow).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Worksheets("Sheet1").Range("F2:F3"), CopyToRange:=Worksheets("Sheet1").Range("A" & wsRow), Unique:=False ' Sheet3以降のデータ抽出後項目行を削除 If i >= 3 Then Worksheets("Sheet1").Range("A" & wsRow & ":W" & wsRow).Delete shift:=xlShiftUp Next i Application.ScreenUpdating = True End Sub
条件式はFor〜Nextのループ中に条件式内のシート名を置換えています。 データ範囲も異なるようですので、データの開始セル番号も書き換える必要があるようです。 (項目行が開始行となります。フィルタオプションでは項目行も含めたセル範囲を指定します) シート名は配列を使えばループで処理できそうな気がいたします。 実情に合わせてコードを書いてください。『頑張ってください』としか書きようがないです。 上のコードにちょっとコメントを加えて書き換えています。 (Hatch)
まだまだ手がかかりそうです。 ですが、Hatch様のコードで抽出が出来たので、
カスタム出来れば思ったとおり出来ると思えたので頑張れます><b は〜ると
Dim i As Long
Dim lastRow As Long, wsRow As Long
Application.ScreenUpdating = False
' Sheet1のA6以降を削除 lastRow = Worksheets("検索用シート").Range("A65536").End(xlUp).Row If lastRow >= 6 Then Range("A6:W" & lastRow).Delete shift:=xlShiftUp End If ' 条件式をF3にSheet2用の数式を入力 Worksheets("検索用シート").Range("F3").Formula = "=OR(AND(Sheet2!G4=検索用シート!C3,検索用シート!E3=Sheet2!H4),AND(検索用シート!C3=Sheet2!I4,検索用シート!E3=Sheet2!J4),AND(Sheet2!K4=検索用シート!C3,検索用シート!E3=Sheet2!L4),AND(検索用シート!C3=Sheet2!M4,検索用シート!E3=Sheet2!N4),AND(Sheet2!O4=検索用シート!C3,検索用シート!E3=Sheet2!P4),AND(検索用シート!C3=Sheet2!Q4,検索用シート!E3=Sheet2!R4),AND(Sheet2!S4=検索用シート!C3,検索用シート!E3=Sheet2!T4))" 'フィルタオプションの設定でデータ抽出 For i = 2 To 9 ' Sheet3以降の条件式(シート名を入れ替えています) If i >= 3 Then Worksheets("検索用シート").Range("F3").Replace "Sheet" & i - 1, "Sheet" & i End If ' データシートの最終行を取得 lastRow = Worksheets("Sheet" & i).Range("A65536").End(xlUp).Row ' Sheet2の時、Sheet1の抽出先を6行目をwsRowに入れる If i = 2 Then wsRow = 6 Else ' Sheet1の最終行をwsRowに入れる wsRow = Worksheets("検索用シート").Range("A65536").End(xlUp).Row + 1 End If ' フィルタオプションの設定 Worksheets("Sheet" & i).Range("A3:W" & lastRow).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Worksheets("検索用シート").Range("F2:F3"), CopyToRange:=Worksheets("検索用シート").Range("A" & wsRow), Unique:=False
' Sheet3以降のデータ抽出後項目行を削除 If i >= 3 Then Worksheets("検索用シート").Range("A" & wsRow & ":W" & wsRow).Delete shift:=xlShiftUp Next i Application.ScreenUpdating = True End Sub
とりあえずsheet1の名前変更から。
Sheet2〜9の頭に2行追加。
A列は必ず2件以上入力されていなければならない?
フィルタオプションの都合なのでしょうか。
とここまで行けました。
あとはSheet2〜9までの名前をA社、B社などに変更。
それが出来ればいったん運用してみようと思います。
がんばりますが実際ここからは難しそうです ><b は〜ると
最終行を調べるのにA列をチェックしています。 例えば、lastRow = Worksheets("検索用シート").Range("A65536").End(xlUp).Row のようなところ。 例えば、データ行で必ずデータが入力される列が「C列」なら lastRow = Worksheets("検索用シート").Range("C65536").End(xlUp).Row とします。 ちょっと手を加えました。 最終行のチェックをC列に変更 シート名がA社〜H社の場合 データがないシート(項目行は有るとしています)は抽出をしない。 こんな感じ↓になりました。 (Hatch) Sub test02() Dim i As Long Dim lastRow As Long, wsRow As Long Dim wsName(9) As String 'シート名を配列に入れます。For〜Nextのi=2に合わせて2〜9の配列にしています。 wsName(2) = "A社": wsName(3) = "B社": wsName(4) = "C社": wsName(5) = "D社" wsName(6) = "E社": wsName(7) = "F社": wsName(8) = "G社": wsName(9) = "H社" Application.ScreenUpdating = False ' 検索用シートのA6以降を削除 lastRow = Worksheets("検索用シート").Range("C65536").End(xlUp).Row If lastRow >= 6 Then Range("A6:W" & lastRow).Delete shift:=xlShiftUp End If ' 条件式を検索用シートのF3セルにA社用の数式を入力 Worksheets("検索用シート").Range("F3").Formula = "=OR(AND(A社!G2=検索用シート!C3,検索用シート!E3=A社!H2),AND(検索用シート!C3=A社!I2,検索用シート!E3=A社!J2),AND(A社!K2=検索用シート!C3,検索用シート!E3=A社!L2),AND(検索用シート!C3=A社!M2,検索用シート!E3=A社!N2),AND(A社!O2=検索用シート!C3,検索用シート!E3=A社!P2),AND(検索用シート!C3=A社!Q2,検索用シート!E3=A社!R2),AND(A社!S2=検索用シート!C3,検索用シート!E3=A社!T2))" 'フィルタオプションの設定でデータ抽出 For i = 2 To 9 If i >= 3 Then Worksheets("検索用シート").Range("F3").Replace wsName(i - 1), wsName(i) End If lastRow = Worksheets(wsName(i)).Range("C65536").End(xlUp).Row 'データ行が項目行を含めて2行以上であったら抽出する。そうでなかったら次のファイルへ '1行目が項目行の場合 例えば項目行が3行目なら「lastRow > 4」とする If lastRow > 2 Then If i = 2 Then wsRow = 6 Else wsRow = Worksheets("検索用シート").Range("C65536").End(xlUp).Row + 1 End If Worksheets(wsName(i)).Range("A1:W" & lastRow).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Worksheets("検索用シート").Range("F2:F3"), CopyToRange:=Worksheets("検索用シート").Range("A" & wsRow), Unique:=False If i >= 3 Then Worksheets("検索用シート").Range("A" & wsRow & ":W" & wsRow).Delete shift:=xlShiftUp End If Next i Application.ScreenUpdating = True End Sub
OR(AND(A社!G2=検索用シート!C3,検索用シート!E3=A社!H2)の部分をG4、H4とすべて4に変更
If lastRow > 2 Then を > 4 に変更
そしてボタンをトン!
するとC列が右にコピーされて抽出されました。
C3とE3の条件を満たしたデータではあるのですが、C列とD列の情報がE列以降にコピーされて出て来てしまいました。
現在その現象を検証中です。 ><b は〜ると
>OR(AND(A社!G2=検索用シート!C3,検索用シート!E3=A社!H2)の部分をG4、H4とすべて4に変更 なら、 Worksheets(wsName(i)).Range("A1:W" & lastRow).AdvancedFilter Action:=xlFilterCopy, _ の部分で、データシートの項目行をA1をA3に変更。 でどうしょうか・・・ 後、気になるのは、前にちょこっと書いてあるし、 サンプルのファイルを見て貰えば判ると思いますが、 各シートの項目を工程1〜工程7,日程1〜日程7に変更しています。 同名の項目があるとうまく抽出されませんので、それぞれの列の項目は 区別できるように異なった項目名にします。 今回は日程と工程の後ろに数字を付けて区別しています。 (Hatch)
おっしゃるとおりで、1〜7の追記を忘れていました。コピーファイルでテストしていた為、
正規ファイルには1〜7を振っていない状態でした。
今回は大変勉強になりました。有難う御座います (^-^b
Sub 抽出()
Dim i As Long
Dim lastRow As Long, wsRow As Long
Dim wsName(9) As String
'シート名を配列に入れます。For〜Nextのi=2に合わせて2〜9の配列にしています。 wsName(2) = "A社": wsName(3) = "B社": wsName(4) = "C社": wsName(5) = "D社" wsName(6) = "E社": wsName(7) = "F社": wsName(8) = "G社": wsName(9) = "H社" Application.ScreenUpdating = False ' 検索用シートのA6以降を削除 lastRow = Worksheets("検索用シート").Range("C65536").End(xlUp).Row If lastRow >= 6 Then Range("A6:W" & lastRow).Delete shift:=xlShiftUp End If ' 条件式を検索用シートのF3セルにA社用の数式を入力 Worksheets("検索用シート").Range("W3").Formula = "=OR(AND(A社!G4=検索用シート!C3,検索用シート!E3=A社!H4),AND(検索用シート!C3=A社!I4,検索用シート!E3=A社!J4),AND(A社!K4=検索用シート!C3,検索用シート!E3=A社!L4),AND(検索用シート!C3=A社!M4,検索用シート!E3=A社!N4),AND(A社!O4=検索用シート!C3,検索用シート!E3=A社!P4),AND(検索用シート!C3=A社!Q4,検索用シート!E3=A社!R4),AND(A社!S4=検索用シート!C3,検索用シート!E3=A社!T4))"
'検索用シートのF列をカウントする
Worksheets("検索用シート").Range("C1").Formula = "=COUNT(F7:F200)"
'フィルタオプションの設定でデータ抽出 For i = 2 To 9 If i >= 3 Then Worksheets("検索用シート").Range("W3").Replace wsName(i - 1), wsName(i) End If lastRow = Worksheets(wsName(i)).Range("C65536").End(xlUp).Row 'データ行が項目行を含めて2行以上であったら抽出する。そうでなかったら次のファイルへ '1行目が項目行の場合 例えば項目行が3行目なら「lastRow > 4」とする If lastRow > 4 Then If i = 2 Then wsRow = 6 Else wsRow = Worksheets("検索用シート").Range("C65536").End(xlUp).Row + 1 End If Worksheets(wsName(i)).Range("A3:W" & lastRow).AdvancedFilter Action:=xlFilterCopy, _ CriteriaRange:=Worksheets("検索用シート").Range("W2:W3"), CopyToRange:=Worksheets("検索用シート").Range("A" & wsRow), Unique:=False If i >= 3 Then Worksheets("検索用シート").Range("A" & wsRow & ":W" & wsRow).Delete shift:=xlShiftUp End If Next i Application.ScreenUpdating = True End Sub
F列の数量をカウントして件数を求めています。
7行目以降のX列に=IF(F7="","","○")と入れC1にCOUNTIFで件数を求めて見ましたが、
マクロを実行していくとX列関数の参照セルがおかしくなってしまい悩んでいましたが、
コードに見真似で式を追加したら出来ました (^-^V
勉強になりました。有難う御座います。 は〜ると
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.