条件にマッチする行を抽出するVBAを教えてください

アイデア、またはVBAプログラムの例を教えていただきたく、質問させていただきます

excelで、添付画像のようなリスト管理表を作っています。
リストは600行近くになります。
やりたいことは、D3またはE3に商品名または保管庫を入力すると、リスト内から、合致する行だけが抽出される、というもの。
D3とE3は、どちらか片方にのみ条件が入る。D3とE3の内容を変更するとリアルタイムで抽出結果も変更されるようにしたい。
触る人が初心者なので、難しい作業を一切せずに、D3またはE3を打ちかえるだけで必要な項目だけのリストとなり、印刷するだけでいいようにしたいわけです。

本来ならオートフィルタですればいい話ですが、どうしてもD3という離れたセルの入力内容で抽出したいのです。

VBAでなく、D3のセル内容を使ってD8～のオートフィルタが行えるなら、それが一番理想です。
が、自分でやってみた限りはできませんでした。

フィルタオプションならどうかとやってみたところ、一回目は抽出できました。しかし、D3またはE3の条件を変更しても、リアルタイムで抽出結果が切り変わらない。
フィルタオプションの抽出結果を別のセルに出せばいいのですが、そうすると無駄な情報が残り、ただ印刷しただけでOK・・というわけにいきません。（印刷範囲を区切るとかでなく、シートの見栄えが必要な情報だけにならないと…扱う初心者が混乱します）


自分なりには、VBAにより、　D3・E3のセル内容が書き換わったらフィルタオプションの抽出結果をいったん同シートの別セルに出し、抽出結果部分だけを別のシートにカット＆ペースト成形。そのシートを印刷させればよい。
という考えになりましたが、やってみたら、なぜか別のブックに同じものが形成され、抽出した結果だけ単独のデータにできません。

そもそももっと良いアイデアがあればそれをおしえていただきたい。
あるいは、VBAで目的達成できるように問題点をご指摘ください。


一応、プログラムを書いておきます



■添付画像のデータが入っているシート（『一覧』という名前のシート）内コード

Private Sub Worksheet_Change(ByVal Target As Range)
'

If Target.Column = 4 Then
If Target.Row >= 3 And Target.Row <= 3 Then

Call Filter
Call copy

End If
End If

End Sub

■サブルーチンFilter()　標準モジュールに記載
Sub Filter()

' Filter Macro

'フィルタオプションを使って同シート内「D1100」以降に抽出結果を出します
ActiveWorkbook.Worksheets("一覧").Select

'一覧表はD7～F1000。検索条件はD2～F３までの範囲に名前を付けたもの
Range("一覧表").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"検索条件"), CopyToRange:=Range("D1100"), Unique:=False

Range("A1").Select
End Sub


■サブルーチンcopy()　標準モジュールに記載
Sub copy()
'
' copy Macro
'
'抽出された内容（45行目～100行目まで）を別のシートにコピーします

ActiveWorkbook.Worksheets("一覧").Select
Rows("45:100").Select
Selection.Cut
ActiveWorkbook.Worksheets("抽出結果").Select
Rows("4:4").Select
Selection.Insert Shift:=xlDown
Range("A1").Select


End Sub

No.2 ベストアンサー 回答者： yaritsusozai 回答日時： 2014/06/24 22:56

追記:

では、当方で検証したサンプルコードを載せますので、ご参考に。結果提示用に「抽出結果」と名付けたまっさらなシートを予め用意しておいてください。

と、その前に注意点。
ご質問内容では、シートモジュールや標準モジュール等、複数のモジュールにコードが分散していますが、今回の処理内容では、モジュールを分ける意味がありません。シートモジュールのワークシートチェンジイベント1本で十分です。従って、ご案内するコードは、一覧表のあるシートのシート見出しを右クリック→コードの表示から呼び出した画面に書き込み、入力が終わったら、ファイルタブ→終了してexcelに戻る、としてください。

それと、クライテリアを使うと、倉庫1の検索で倉庫10以降もピックアップされてしまうので、1は全角で10以降は半角にするなど、元ネタに区別をしてください。

また、利用者のなかにビギナーがいるのであれば、セルのロックと保護を使い、一覧シートのD3:E3しか操作出来ないようにする、入力規則を使って、商品1,商品2といったリストから選ばせる、等の工夫も考えられます。それらをどう併用するかによって適切なコードも変わってきますので、細部はご自身で調整してください。

Private Sub Worksheet_Change(ByVal Target As Range)

If Application.Intersect(Target, [D3:E3]) Is Nothing Then Exit Sub

Worksheets(”抽出結果”).[A1:C1000].ClearContents

Range(”一覧表”).AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range _
(”検索条件”), Copytorange:=Worksheets(”抽出結果”).Range(”A1”)

End Sub

この回答へのお礼

サンプルコードを書いてくださったのも勿論ありがたかったのですが、注意点や特徴をよく説明してくださって、大変分かりやすかったです。
処理自体は、まだまだ多くの工程を経て完成に向かいますが、質問項目に関しては目標を達成でき、理解が深まったと感じます。
総じてyaritsusozaiさんおひとかたのみの回答でしたが、よいかたと巡りあえて幸運でした。
このプログラムと解説、大事に活用させていただきます。
ありがとうございました(*^^*)

お礼日時：2014/07/07 08:28

No.1 回答者： yaritsusozai 回答日時： 2014/06/23 00:11

抽出結果を1100行以降に書き出したのに、その後45～100行を選んでコピーしているのが意味不明ですが…

AdvancedFilterのCopytorangeを、

:=Worksheets(”抽出結果”).Range(”A1”)
にすれば、どこかに抽出したデータをさらに別シートにコピーするといったような”二度手間”は省けます。

もう一点、新たな抽出の際、前回抽出したものが残っているとごっちゃになる恐れがあるので、
AdvancedFilterを使う前に、

Worksheets(”抽出結果”).[A1:C1000].ClearContents
などで、宛先をクリアにしておくと良いと思います。

この回答への補足

>抽出結果を1100行以降に書き出したのに、
>その後45～100行にコピーしているのが意味不明

すみません、データを少なくして実行チェックを行っていたので、それが残ってました…
この部分は正しく100行以降にコピーするように直して実行しています。


>AdvancedFilterのCopytorangeを、
>:=Worksheets(”抽出結果”).Range(”A1”)にすれば、

それが…マクロを記録する際にも別シートは選べませんでしたし、
VBAコード側でこれを書き込んでみましたが、抽出結果が現れませんでした…


>Worksheets(”抽出結果”).[A1:C1000].ClearContents
>などで、宛先をクリアに

これは確かにしておくべき、と思いました。ありがとうございます。

補足日時：2014/06/24 21:06