【Excel2010】リストから部分一致を抽出する

使用ＯＳ：Windows7

Excel2010を利用しています。
Ｓｈｅｅｔ１には添付写真のように品目名の下に３０００件ー５０００件ほどの資材などの名前があります。
Ｓｈｅｅｔ２のＡ１にある検索したい語句を入れるとＳｈｅｅｔ１のＢ列から部分一致する列を抜き出しＳｈｅｅｔ２のＡ３以下にその情報が記載されるようにしたいと思っています。

例としてＳｈｅｅｔ２のＡ１に『コーススレッド』と入力するとＳｈｅｅｔ２のＡ３の行にはＳｈｅｅｔ１の２行目、Ａ４の行にはＳｈｅｅｔ１の５行目が記載されるようにしたいです。

オートフィルタや検索を使えばいいじゃないかと言われるかもしれないですが、そういった操作ができない年長の方が使えることを目的としたいので、教えていただけないでしょうか？ＶＢＡが絡んでも問題ないです。よろしくお願いします。

No.4 回答者： MackyNo1 回答日時： 2012/02/22 13:27

数式入力セル(表示データ数）が多くなると（20件以上該当データがあるような場合）シートの動きが重くなりますので、あまりお勧めできませんが、数式で対応するなら以下のような数式を使うことになります。

例えばSheet2のA3セルにA1セルの文字列を含むB列のデータを抽出するなら以下の式を入力し、下方向にオートフィルコピーします。

=INDEX(Sheet1!B:B,SMALL(INDEX(ISERR(FIND($A$1,Sheet1!$B$2:$B$5000))*10000+ROW($B$2:$B$5000),),ROW(A1)))&""

なお、上記の数式を右方向にオートフィルすれば該当の行のデータを表示できますが、計算負荷を少なくするするには、B3セルから右は以下のようなIF関数で対応するのが良いと思います。

=IF(A3="","",INDEX(Sheet1!C:C,SMALL(INDEX(ISERR(FIND($A$1,Sheet1!$B$2:$B$5000))*10000+ROW($B$2:$B$5000),),ROW(A1))))

No.3 回答者： mt2008 回答日時： 2012/02/22 13:10

抽出部分の消去が面倒くさかったので抽出結果はSheet2のC:E列に出すものとします。

また、Sheet2のA1には「品目名」と入っていて、A2に品目名を手入力するものとします。

コマンドボタンか何かを用意して、手入力後に以下のマクロを動かしてください。

Sub Sample()
　　Sheets("Sheet2").Columns("C:E").ClearContents
　　Sheets("Sheet1").Range("B:D").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet2").Range("A1:A2"), CopyToRange:=Sheets("Sheet2").Range("C1")
End Sub

No.2 回答者： KURUMITO 回答日時： 2012/02/22 12:02

分かり易い方法は作業列を作って対応する方法です。

シート１のＥ２セルには次の式を入力して下方にオートフィルドラッグコピーします。

=IF(COUNTIF(B2,"*"&Sheet2!$A$1&"*"),MAX(E$1:E1)+1,"")

シート２のＡ１セルには検索したい文字を入力します。
Ａ３セルには次の式を入力したのちに右横方向にオートフィルドラッグコピーしたのちに下方にもオートフィルドラッグコピーします。

=IF(OR(ROW(A1)>MAX(Sheet1!$E:$E),COLUMN(A1)>3),"",INDEX(Sheet1!$B:$D,MATCH(ROW(A1),Sheet1!$E:$E,0),COLUMN(A1)))

No.1 回答者： keithin 回答日時： 2012/02/22 11:31

＞３０００件ー５０００件ほどの資材などの名前があります。

関数で並べるのは現実的ではない物量なので，マクロを使います。


準備：
シート２の１行目にシート１と同じ項目を並べる
Ｂ１，Ｃ１，Ｄ１に品目名，大分類，大分類番号のように
シート２の２行目に検索ワードを記入することにする

シート２の４行目以下に抽出する


手順：
シート２のシート名タブを右クリックしてコードの表示を選ぶ
現れたシートに下記をコピー貼り付ける

private sub worksheet_change(byval Target as excel.range)
　set target = application.intersect(target, range("2:2"))
　if target is nothing then exit sub

　range("A5:A" & application.max(5, cells.specialcells(xlcelltypelastcell).row)).entirerow.delete shift:=xlshiftup
　if application.counta(target) = 0 then exit sub

　worksheets("Sheet1").range("B:D").advancedfilter _
　　action:=xlfiltercopy, _
　　criteriarange:=range("B1:D2"), _
　　copytorange:=range("B4:D4")
end sub

ファイルメニューから終了してエクセルに戻る
２行目に検索語を記入する。