EXCEL VBA 別シートの文字をシート内で検索

excel2003　VBAで　SHEET2に格納されているセルの文字をSHEET１のＢ列1～9000程度までの文字列の中で一致または部分一致するものがあればそのセル（Ｂ列のセル）をSHEET3に順次A列に出力したいのですが、うまくできません。SHEET2に格納されている場所はＡ列で（SHEET1、SHEET2の文字とも増える可能性あり）

宜しくお願いします。

No.4 ベストアンサー 回答者： keithin 回答日時： 2012/07/16 12:34

sub macro1r1()

　dim h as range
　dim c as range
　dim c0 as string

　worksheets("Sheet3").cells.clearcontents
　for each h in worksheets("Sheet2").range("A1:A" & worksheets("Sheet2").range("A65536").end(xlup).row)
　　if h <> "" then
　　　set c = worksheets("Sheet1").range("B:B").find(what:=h.value, lookin:=xlvalues, lookat:=xlpart)
　　　if not c is nothing then
　　　　c0 = c.address
　　　　do
　　　　　worksheets("Sheet3").range("A65536").end(xlup).offset(1).value = c.value
　　　　　set c = worksheets("Sheet1").range("B:B").findnext(c)
　　　　loop until c.address = c0
　　　end if
　　end if
　next

　worksheets("Sheet3").select
　range("A1:B1") = array("res", "work")
　range("B2:B" & range("A65536").end(xlup).row).formula = "=MATCH(A2,Sheet1!B:B,0)"
　range("A:B").sort key1:=range("B1"), order1:=xlascending, header:=xlyes
　range("B:B").clearcontents
end sub


sub macro2r1()
　dim Target as range
　dim Crit as range
　dim r as long

　worksheets("Sheet3").cells.clearcontents
　with worksheets("sheet1")
　.range("1:1").insert shift:=xlshiftdown
　.range("B1") = "myList"
　set target = .range(.range("B1"), .range("B65536").end(xlup))
　end with

　with worksheets("sheet2")
　.range("1:1").insert shift:=xlshiftdown
　.range("B:B").insert shift:=xlshifttoright
　.range("A1:B1") = "myList"
　r = .range("A65536").end(xlup).row
　with .range("B2:B" & r)
　　.formula = "=""*""&A2&""*"""
　　.value = .value
　end with
　set crit = .range("B1:B" & r)
　end with

　target.advancedfilter _
　　action:=xlfiltercopy, _
　　criteriarange:=crit, _
　　copytorange:=worksheets("Sheet3").range("A1"), _
　　unique:=false

　worksheets("Sheet2").range("B:B").delete shift:=xlshifttoleft
　worksheets("Sheet2").range("1:1").delete shift:=xlshiftup
　worksheets("Sheet1").range("1:1").delete shift:=xlshiftup
end sub

この回答への補足

ご回答ありがとうございます。
Macro2のパターンでは希望通りに出力できました。
私の勉強不足でこちらのパターンはあまり理解できていないのですが・・・

Macro1では前回同様並び替えて出力されています。
自分でも修正チャレンジしているのですが・・・

お忙しい中ご回答ありがとうございました。

補足日時：2012/07/16 15:18

この回答へのお礼

敏速な対応、回答ありがとうございました

お礼日時：2012/07/17 20:58

No.3 回答者： atamagawarui5 回答日時： 2012/07/16 10:12

＞検索結果の並び順はソートしない場合はどこを修正すれば良いのでしょうか？

#1です
#2さんへの補足に、割り込み回答
上記確認したいなら、F8で1行ずつデバックしてみてください。
どの時点でソートされているか分かります。
自分で確認しないと覚えないと思いますので。
あえて、コードは示しませんが・・・・

それでも分からない様なら、もう一度、補足でも入れてください。

No.2 回答者： keithin 回答日時： 2012/07/15 19:30

方法１：ベタだけど判りやすい

sub macro1()
　dim h as range
　dim c as range
　dim c0 as string

　for each h in worksheets("Sheet2").range("A1:A" & worksheets("Sheet2").range("A65536").end(xlup).row)
　　if h <> "" then
　　　set c = worksheets("Sheet1").range("B:B").find(what:=h.value, lookin:=xlvalues, lookat:=xlpart)
　　　if not c is nothing then
　　　　c0 = c.address
　　　　do
　　　　　worksheets("Sheet3").range("A65536").end(xlup).offset(1).value = c.value
　　　　　set c = worksheets("Sheet1").range("B:B").findnext(c)
　　　　loop until c.address = c0
　　　end if
　　end if
　next
end sub


方法２：推奨・高速
sub macro2()
　dim Target as range
　dim Crit as range
　dim r as long

　with worksheets("sheet1")
　.range("1:1").insert shift:=xlshiftdown
　.range("B1") = "myList"
　set target = .range(.range("B1"), .range("B65536").end(xlup))
　end with

　with worksheets("sheet2")
　.range("1:1").insert shift:=xlshiftdown
　.range("B:B").insert shift:=xlshifttoright
　.range("A1:B1") = "myList"
　r = .range("A65536").end(xlup).row
　with .range("B2:B" & r)
　　.formula = "=""*""&A2&""*"""
　　.value = .value
　end with
　set crit = .range("B2:B" & r)
　end with

　target.advancedfilter _
　　action:=xlfiltercopy, _
　　criteriarange:=crit, _
　　copytorange:=worksheets("Sheet3").range("A1"), _
　　unique:=false

　worksheets("Sheet2").range("B:B").delete shift:=xlshifttoleft
　worksheets("Sheet2").range("1:1").delete shift:=xlshiftup
　worksheets("Sheet1").range("1:1").delete shift:=xlshiftup
end sub

この回答への補足

早速のご回答ありがとうございます。
非常に助かります。
再度の質問で申し訳ありません。
検索結果の並び順はソートしない場合はどこを修正すれば良いのでしょうか？

補足日時：2012/07/16 09:39

No.1 回答者： atamagawarui5 回答日時： 2012/07/15 19:26

VBAは組めるものとして、間単に内容説明します。

最初にSHEET3クリア

次に、SHEET１の最終行求めます
Range("A1").End(xlUp)で最終行なのでその値まで繰り返せば

VLOOKUP関数を式にしてください。
範囲はSHEET2（値はTRUE）
FOR～NEXT（最終行）

出力が出せますので、それをSHEET3に出力してください。

その後に
その出力されたものを重複削除し、並べ替えをすれば普通に出る
と思います。

考え方はこの順番です。
VBAはこの考え方で組めます。

サンプルコードについての要求はなようなので、考え方のみ回答し
ます。

この回答への補足

早速のご回答ありがとうございます。
VBA初心者なので試行錯誤状態なので、考え方も大変参考になります。
ありがとうございます。

補足日時：2012/07/16 09:51

この回答へのお礼

敏速なアドバイスありがとうございました。

お礼日時：2012/07/17 21:00