[[20041013161646]]　『複数シートから抽出方法で？です』（は～ると）　ページの最後に飛ぶ

『複数シートから抽出方法で？です』（は～ると）

 お世話になります。工程と日程で抽出し、一覧印刷をする為にデータを入力しました。
 Sheet1は抽出用シートに使用し、Sheet2～Sheet9にMAX500行、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様　ありがとうございます。
データ量は気にしています。　データファイルとコピー用ファイルと
抽出ファイルの３ファイルに分けた方が宜しいでしょうか？
サンプルファイルをさわってみます。

  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

有難う御座います。
この方法を利用してみようとがんばったのですが、どうしてもエラーになってしまいます。
カスタムしてみようと試みましたが撃沈；；
実は、各シートには名前が振ってあるのです。Ａ社、Ｂ社、Ｃ社という様に８シートに
Sheet１には抽出用シートとしてあります。
そしてデータはA3から項目行でデータはA4スタートになっています。ここもうまくいかない原因になっています。１，２行結合してあり件数をカウントしておりますので。。
ですからiに置き換えられた部分を前回の時はそれぞれシートの名前を入れて書いてみました。
範囲のエラーが出ないところまで行けたのですが、条件に合わないデータが抽出されてしまってました。
今回のは今チャレンジ中です。＞＜ｂ　は～ると

 条件式はFor～Nextのループ中に条件式内のシート名を置換えています。
 データ範囲も異なるようですので、データの開始セル番号も書き換える必要があるようです。
 (項目行が開始行となります。フィルタオプションでは項目行も含めたセル範囲を指定します)
 シート名は配列を使えばループで処理できそうな気がいたします。
 　実情に合わせてコードを書いてください。『頑張ってください』としか書きようがないです。
 　上のコードにちょっとコメントを加えて書き換えています。　　(Hatch)

Hatch様　ありがとうございます。
データのコピーを使い1行目が項目行2行目からデータのようにし、Sheet１～９に名前を戻してみました。
でもエラーが出たので、うぅと思ったのですが、どうやらA列は必ず入力されていないといけないと思い２～９のシートにＡ列を入力してみました。
そしたらうまく抽出出来ました。う～ん
Ａ列、Ｂ列は必ずしも入力されていない。
Ｃ列Ｄ列Ｅ列は必ず入力されている。
２～９すべてのシートに入力がされていない時もある。
Ａ社～Ｂ、Ｃ、Ｄ社まで入力あり、Ｅ社から未入力など。

まだまだ手がかかりそうです。　ですが、Hatch様のコードで抽出が出来たので、
カスタム出来れば思ったとおり出来ると思えたので頑張れます＞＜b　は～ると

Sub 抽出()

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

とりあえずsheet１の名前変更から。

Sheet２～９の頭に２行追加。

Ａ列は必ず２件以上入力されていなければならない？　

フィルタオプションの都合なのでしょうか。

とここまで行けました。
あとはSheet２～９までの名前をＡ社、Ｂ社などに変更。

それが出来ればいったん運用してみようと思います。
がんばりますが実際ここからは難しそうです　＞＜ｂ　は～ると

 最終行を調べるのに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　を　＞　４　に変更

そしてボタンをトン！

するとＣ列が右にコピーされて抽出されました。
Ｃ３とＥ３の条件を満たしたデータではあるのですが、Ｃ列とＤ列の情報がＥ列以降にコピーされて出て来てしまいました。
現在その現象を検証中です。　＞＜ｂ　は～ると

 >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)

Hatch様　有難う御座いました。　無事抽出が出来る様になりました。；；感謝

おっしゃるとおりで、１～７の追記を忘れていました。コピーファイルでテストしていた為、
正規ファイルには１～７を振っていない状態でした。
今回は大変勉強になりました。有難う御座います　（＾-＾ｂ

最終的にこうなりました。

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))"

'検索用シートのＦ列をカウントする
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列の数量をカウントして件数を求めています。
７行目以降のX列に=IF(F7="","","○")と入れC1にCOUNTIFで件数を求めて見ましたが、
マクロを実行していくとX列関数の参照セルがおかしくなってしまい悩んでいましたが、
コードに見真似で式を追加したら出来ました　（＾-＾Ｖ
勉強になりました。有難う御座います。　は～ると

コメント返信：

[ 一覧(最新更新順) ]

[[20041013161646]] 『複数シートから抽出方法で？です』（は～ると） ページの最後に飛ぶ

[[20041013161646]]　『複数シートから抽出方法で？です』（は～ると）　ページの最後に飛ぶ