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

質問

ご質問です。
複数キー中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）

回答No.1

keithin · ベストアンサー

こんなカンジですかね。

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で入力し，右にコピー，下にコピー。

お礼

＞worksheets("Sheet1").cells(c.row, 4 + h.column) = 1　の発想がなかったので出来なかったとわかりました。また、処理コメントも書いていただいてよくわかりました。すぐのお返事ありがとうございます。大変助かりました。

回答No.4

imogasi

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

お礼

ロジックを私の代わりにご説明していただきありがとうございます。（詳しく書くよう心がけます。）一時的なテキストを生成して検索している他の方のやり方を理解するのに役立ちました。感謝いたします。誤記（vakueではなくvalueです)も訂正いたします。

回答No.3

mt2008

こんな方法も……

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

お礼

>sTarget = .Cells(i, 1) & .Cells(i, 2) & .Cells(i, 3) & .Cells(i, 4)
'A～D列の文字列を結合　　　　　　　　
>'条件と一致する文字列を削除
>sTarget2 = Replace(sTarget2, sWord, "")

と私の中では新境地のコードです。今後のコード学習につながるので助かります。コードもきちんと動きました。ありがとうございます。

回答No.2

merlionXX

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

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

お礼

>ReDim myY(1 To UBound(myW, 1), 1 To 3)
>If InStr(myW(j, i), myX(n, l)) > 0 Then
という私には初めてのやり方なので勉強になります。コードもすぐ動いて助かりました。学習素材に最適なご回答ありがとうございます。