マクロ　複数キーと一致する行を条件選択、フラグ入れ

Question

ご質問です。
複数キー中1つ以上のキーが部分一致する行（複数列で構成)を選択し、フラグを入れたいです。
下記の例で言いますと、Sheet1の１行に、Sheet2の列中の1つ以上が部分一致する場合、1と記入したいと思います。
（Sheet１）
   　A  　　　　B  　　　　　C　　　　　　D　　　　　　　E　　　　　　　　　　　B　　　　　　　　　　C
1)　　　　　　　　　　　　　　　　　　　　　（条件1チェック）　（条件2チェック）（条件3チェック）
2) 犬あ　　猿い　　　う鳥　　　え魚　　　　　　　1　　　　　　　　　1
3) 豚い　　熊え　　　ね兎　　　蛇ら　　　　　　　　　　　　　　　　　　　　　　　　　　　　1
4) 猫た　　龍さ　　　魚み　　　羊り　　　　　　　1　　　　　　　　　　　　　　　　　　　　 1
・・・・500件続くアンケートです。
(Sheet2)
    　A    　   　　 　B 　   　　　     C        　
1)　（条件1） 　（条件2）　（条件3）
2)　犬　　　　　猿　　　　　豚
3)　猫　　　　　馬　　　　　羊
4)　狐　　　　　牛　　　　　熊
FindとLoopで作ってみましたが、上記で言うところのSheet1の先頭行しか検索してくれませんでした。どなたか、FindとLoop（またはFor)で教えてくださいますでしょうか。
↓できなかった私の作成物
With WS(2).Range("a2:c5")
           Set c = .Find(What:=myKey, LookIn:=xlValues, LookAt:=xlPart, _
                            SearchOrder:=xlByColumns, MatchByte:=False)
          If Not c Is Nothing Then
              fAddress = c.Address
              Do
                  WS(2).Cells(m,1).vakue=1
                  Set c = .FindNext(c)
                      If c.Address = fAddress Then Exit Do
              Loop
３日悩んで、大変困っております。よろしくお願いします。（OS：WindosXP、Office2003）

keithin · Accepted Answer

こんなカンジですかね。

sub macro1()
　dim h as range
　dim c as range
　dim s as string
　worksheets("Sheet1").range("E:G").clearcontents

’シート１の中に…
　with worksheets("Sheet1").range("A:D")
’条件を一つずつ調査する
　for each h in worksheets("Sheet2").range("A2:C5")
　　if h <> "" then
　　　set c = .find(what:=h, lookin:=xlvalues, lookat:=xlpart)
　　　if not c is nothing then
　　　　s = c.address
　　　　do
　　　　’あればフラグを立てる
　　　　　worksheets("Sheet1").cells(c.row, 4 + h.column) = 1
　　　　　set c = .findnext(c)
　　　　loop until c.address = s
　　　end if
　　end if
　next
　end with
end sub

＃ちなみに
Ｅ２に
=IF(OR((Sheet2!A$1:A$5<>"")*ISNUMBER(FIND(Sheet2!A$1:A$5&"",$A2:$D2))),1,"")
と記入してコントロールキーとシフトキーを押しながらEnterで入力し，右にコピー，下にコピー。

imogasi · Answer

＞Sheet1の先頭行しか検索してくれませんでした
Findメソッドだけでなく、FINDNEXT[が必要なだけでは。
Googleで「エクセル　VBA　検索」で照会してコードをさがして、真似したら。
初心者にはFind、Findねｘｔは使うのが難しいと思う。
しかし、まあそれは本件で使っているのですね。
ーー
質問にロジックの説明が無く、ありふれたケースではないので、判るのに時間がかかる。
実例だけでなく、しっかり文章でも説明のこと。
ーー
ロジックは、検索対象としては行単位で考えるらしい。本件ではその範囲はSheet1の各行１－３列
検索語としては第１回目が、条件１がSheet2の犬。次いで猫の検索をまわさないとならないようだが、質問のコードではそれが見えないが。
犬と猫の検索をVBAで１度でやる方法は無いと思う。IF分ならORを使って、やれそうだがSheet2のA列のように多いとそれも使えない。
だからこれらのループをFor Nextの総なめ法でテスト的にコードを作り、結果が正しくなったら、それからFind法に置き換えたら。
Sheet1の「ある１行」の列の判別ループ
Sheet2の条件の各列の各行のループ
条件が条件１、条件２・・と複数あるループ。
を見据える。
ーー
).vakue=1　はValue
でしょう。

mt2008 · Answer

こんな方法も……

Sub sample()
Dim i, j, k
Dim sTraget As String
Dim sTraget2 As String
Dim sWord As String

With Worksheets("Sheet1")
　　For i = 2 To .Range("A2").End(xlDown).Row
　　　　sTarget = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4) 'A～D列の文字列を結合
　　　　For j = 1 To 3 '条件
　　　　　　sTarget2 = sTarget
　　　　　　For k = 1 To 3
　　　　　　　　sWord = Worksheets("Sheet2").Cells(k + 1, j).Text
　　　　　　　　'条件と一致する文字列を削除
　　　　　　　　sTarget2 = Replace(sTarget2, sWord, "")
　　　　　　Next k
　　　　　　'もとの結合文字列より短ければ一致あり
　　　　　　If Len(sTarget) > Len(sTarget2) Then .Cells(i, j + 4) = 1
　　　　Next j
　　Next i
End With
End Sub

merlionXX · Answer

もう検索での回答が出ていますので配列に入れて比較する方法の一例です。

Sub test01()
　　Dim myW, myX, myY
　　Dim i As Long, j As Long, l As Long, n As Long
　　Dim ws(1 To 2) As Worksheet
　　Set ws(1) = Sheets("Sheet1")
　　Set ws(2) = Sheets("Sheet2")
　　With ws(1)
　　　myW = .Range(.Range("A2:D2"), .Range("A2:D2").End(xlDown)).Value
　　End With
　　With ws(2)
　　　myX = .Range(.Range("A2:C2"), .Range("A2:C2").End(xlDown)).Value
　　End With
　　ReDim myY(1 To UBound(myW, 1), 1 To 3)
　　For i = 1 To 4
　　　　For j = 1 To UBound(myW, 1)
　　　　　　For l = 1 To 3
　　　　　　　　For n = 1 To UBound(myX, 1)
　　　　　　　　　　If InStr(myW(j, i), myX(n, l)) > 0 Then
　　　　　　　　　　　　myY(j, l) = 1
　　　　　　　　　　　　Exit For
　　　　　　　　　　End If
　　　　　　　　Next n
　　　　　　Next l
　　　　Next j
　　Next i
　　ws(1).Range("E2").Resize(UBound(myW, 1), 3).Value = myY
End Sub

マクロ 複数キーと一致する行を条件選択、フラグ入れ

こんなカンジですかね。

＞Sheet1の先頭行しか検索してくれませんでした

こんな方法も……

もう検索での回答が出ていますので配列に入れて比較する方法の一例です。

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

マクロ　複数キーと一致する行を条件選択、フラグ入れ