プロが教えるわが家の防犯対策術!

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

宜しくお願いします。

A 回答 (4件)

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
    • good
    • 2
この回答へのお礼

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

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

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



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

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

方法1:ベタだけど判りやすい


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


方法2:推奨・高速
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
    • good
    • 0

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



最初にSHEET3クリア

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

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

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

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

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

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

この回答への補足

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

補足日時:2012/07/16 09:51
    • good
    • 0
この回答へのお礼

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています