findは動くがfindnextがマクロで動きません。記述は同じはずなのですが…

sheet1の●列のセルをsheet2の◆列で検索し、ヒットがあればsheet1の同行数列後の数値をsheet2のヒット行数列後のセルに入力する…というマクロを作っています。
sheet2でのヒットが複数あるため、findとfindnextを利用しているのですが
findのみの場合は動くのに、findnextについては全く反応しないマクロが出来てしまいました。
不格好な記述ですが、原因がお解りになる方がいらっしゃいましたらご教授頂ければ幸いです。
findとfindnextのルールは調べた限りでは守っているはずなのですが、原因がわからず困っております。


Sub test()

Application.ScreenUpdating = False


Dim i As Long
Dim ii As Long
Dim p As Long

Worksheets(1).Activate
With ActiveSheet
x = .UsedRange.Cells(.UsedRange.Count).Row
End With
Worksheets(2).Activate
With ActiveSheet
k = .UsedRange.Cells(.UsedRange.Count).Row
End With

For i = 1 To x

Dim lngYLine As Long
Dim intXLine As Integer
Dim Obj As Object

Dim fnd As Range
Dim fnd2 As Range
Dim adr As String

Set Obj = ActiveWorkbook.Worksheets(2).Range("I1", Cells(k, 9)).Find(What:=ActiveWorkbook.Worksheets(1).Cells(i, 1).Value, LookIn:=xlValues, LookAt:=xlPart)


If Obj Is Nothing Then '見つからなかった場合の処理
ActiveWorkbook.Worksheets(1).Cells(i, 1).Interior.ColorIndex = 3
Else '見つかった場合の処理
ActiveWorkbook.Worksheets(1).Cells(i, 1).Interior.ColorIndex = 4
Set fnd = ActiveWorkbook.Worksheets(2).Range("I1", Cells(k, 9)).Find(What:=ActiveWorkbook.Worksheets(1).Cells(i, 1).Value, LookIn:=xlValues, LookAt:=xlPart)
adr = fnd.Address

q = Obj.Row

p = ActiveWorkbook.Worksheets(1).Cells(i, 18).Value

ActiveWorkbook.Worksheets(2).Cells(q, 14) = p

End If

'=======
Do
Set fnd2 = ActiveWorkbook.Worksheets(2).Range("I1", Cells(k, 9)).FindNext(fnd)
If fnd2.Address = adr Then '上書きしたfndのアドレスが最初のfndアドレスと一緒なら終了
Exit Do
Else 'そうでなければ以下の処理を続ける
ActiveWorkbook.Worksheets(1).Cells(i, 1).Interior.ColorIndex = 4
q = Obj.Row

p = ActiveWorkbook.Worksheets(1).Cells(i, 18).Value
ActiveWorkbook.Worksheets(2).Cells(q, 14) = p
End If
Loop

'=======

Next i

Application.ScreenUpdating = True


End Sub

No.3 ベストアンサー 回答者： WindFaller 回答日時： 2017/06/06 11:43

こんにちは。

もう2名も先に回答がついたので、これで十分なのですが、思うことがあり参加させていただきます。

ふつうは、　範囲.Find ->見つかれば、->範囲.FindNext
範囲を新たに設定することはないので、通常はWith ステートメントでつなぎます。

Set Obj = ActiveWorkbook.Worksheets(2).Range..Find(...
Set fnd = ActiveWorkbook.Worksheets(2).Range..Find(....
Do
Set fnd2 = ActiveWorkbook.Worksheets(2).Range.. FindNext(fnd)　'*
Loop
*これは、戻り値をfnd2にしたらつながりませんね。


> Worksheets(1).Activate
>　With ActiveSheet
>　　x = .UsedRange.Cells(.UsedRange.Count).Row
>　End With

決して、UsedRangeで最後尾を求める方法が悪いわけではないのですが、最後のセルのとり方として、とんでもない数字が入る要素があるのと、これで検索値を求めると、空白値が入り込む要素が高いです。検索データ列も、被検索列もともに、一列のみのようでしたら、Endプロパティで求めたほうがよいです。

また、私は、ループで使う変数は、短めにするということにしています。

わかりにくくしているのは、最初、変数を全体的に有効利用していないからだと思いました。#2さんの回答と、だいたい注目点はおなじだと思っていますが、もしかしたら、解釈が違っているかもしれません。

私は、検索のxlPart の件ですが、xlWholeにして、検索値 &"*" とワイルドカードを使うことがあります。ただ、一般的に文字列の検索に利用し、数値は、xlWholeで、xlPart は使いません。一旦、検索したものを、桁などを処理して正しいか検査してから、検索値として扱います。

こんなふうに直してみました。

'//
Sub Test2()
　Dim sh1 As Worksheet
　Dim sh2 As Worksheet
　Dim o As Object
''　Dim fnd As Range　'使うのを辞めました。

　Dim Rng As Range
　Dim r As Range
　Dim k As Long
　Dim i As Long
　Dim x As Long
　Dim FirstAddress As String

　Set sh1 = ActiveWorkbook.Worksheets("Sheet1")
　Set sh2 = ActiveWorkbook.Worksheets("Sheet2")

　With sh2
　　Set Rng = .Range("I1", .Cells(Rows.Count, "I").End(xlUp))
　End With
　With sh1
　　x = .Cells(Rows.Count, 1).End(xlUp).Row
　End With

　For i = 1 To x
　　Set r = sh1.Cells(i, 1)
　　If r.Value <> "" Then
　　　Set o = Rng.Find(What:=r.Value, LookIn:=xlValues, LookAt:=xlPart)
　　　If Not o Is Nothing Then
　　　　FirstAddress = o.Address
　　　　Do
　　　　　r.Interior.ColorIndex = 4
　　　　　sh2.Cells(o.Row, 14).Value = sh1.Cells(i, 18).Value
　　　　　Set o = Rng.FindNext(o)
　　　　Loop While Not o Is Nothing And o.Address <> FirstAddress
　　　Else
　　　　r.Interior.ColorIndex = 3
　　　End If
　　End If
　Next
End Sub

この回答へのお礼

詳しくご指摘頂き、ありがとうございます！頂いたマクロで動きました…！
変数がいまいち苦手でついベタ書きをしてしまうのですが、元の記述にも近く大変理解しやすかったです。
ご回答ありがとうございました！

お礼日時：2017/06/06 20:57

No.2 回答者： fujillin 回答日時： 2017/06/06 10:22

こんにちは

すでに指摘がありますが、うまくいかない原因になりそうなのは、
1）Doループの中で
＞Set fnd2 = ActiveWorkbook.Worksheets(2).Range("I1", Cells(k, 9)).FindNext(fnd)
としているため、fndの内容が常に一定（変化しない）なので、fnd2も同じ値を取り続けることになり、対象が複数存在する場合はループを抜けなくなる。

2）検索処理の手順全体が
＞If Obj Is Nothing Then
＞Else
＞End If
＞Do
＞Loop
という構造になっていますが、見つからない場合（Obj is Nothing)でも、後段のDoループの処理は実行されてしまいます。
・・・といったところでしょうか？
そのほかにも、
3）検索値（Worksheets(1)のA列？）の値に空白がある場合にも空白値で検索するけれど・・？
4）検索方法がxlPartなので、違う値でも複数回ヒットする可能性があり、最後にヒットした時の値で上書きされる。
（データの性質上、3）、4）のようなことは起こり得ないのかもしれませんが）
・・・などが気になりますが、これで結果が異なる可能性があるものの、処理が止まることは無いと思います。

また、処理内容とは関係がありませんが、記述方法として、属性値を利用するのに同じドット記法を何度も繰り返していたり、あるいは、同じ処理を複数回繰り返し記述しているように見えますが、変数を利用したり、処理順序を工夫したりすることで、もう少し簡潔に記載できそうな気がします。

ちゃんと確認していないので、行や列がずれてしまっているかも知れませんが、以下のような雰囲気でも処理ができるのではないかと思います。
※ ご提示のコードにはありませんが、セル値が空白の場合に検索をスキップする処理を勝手に追加しています

Sub test()

Dim sh1 As Worksheet, sh2 As Worksheet
Dim searchRange As Range, fnd As Range
Dim rw As Long, cellColor As Integer
Dim addr As String

' 変数の初期設定
Set sh1 = Worksheets(1)
Set sh2 = Worksheets(2)
Set searchRange = sh2.Cells(1, 9).Resize(sh2.Cells(Rows.Count, 9).End(xlUp).Row)

' 元シートの各行でループ
For rw = 1 To sh1.Cells(Rows.Count, 1).End(xlUp).Row
　cellColor = 4
　' 空セルの場合はスキップ
　If sh1.Cells(rw, 1) <> Empty Then
　　Set fnd = searchRange.Find(What:=sh1.Cells(rw, 1).Value, LookIn:=xlValues, LookAt:=xlPart)

　　' 検索できない場合の処理
　　If fnd Is Nothing Then
　　　cellColor = 3

　　' 検索できた場合の処理
　　Else
　　　addr = fnd.Address
　　　Do
　　　　sh2.Cells(fnd.Row, 14).Value = sh1.Cells(rw, 18).Value
　　　　Set fnd = searchRange.FindNext(fnd)
　　　Loop While Not fnd Is Nothing And fnd.Address <> addr
　　End If
　　sh1.Cells(rw, 1).Interior.ColorIndex = cellColor
　End If
Next rw

End Sub

この回答へのお礼

詳しくご指摘頂き、ありがとうございます！
頂いた記述で動きました！
＞fndの内容が常に一定（変化しない）なので、fnd2も同じ値を取り続けることになり、対象が複数存在する場合はループを抜けなくなる。
こちらが特にわかりやすかったです。
fnd=fndのような同じ変数を使う数式の理解が苦手で避けてしまっていたのですが、それが原因となる場合もあるのですね…。感謝いたします。

お礼日時：2017/06/06 20:51

No.1 回答者： めぐみん_ 回答日時： 2017/06/05 18:39

ヘルプより

FindNext メソッド

Find メソッドによって開始された検索を継続します。

－－－－－－－－

とあります。
なら原因は多分

＞Set fnd = ActiveWorkbook.Worksheets(2).Range("I1", Cells(k, 9)).Find(What:=ActiveWorkbook.Worksheets(1).Cells(i, 1).Value, LookIn:=xlValues, LookAt:=xlPart)

＞Set fnd2 = ActiveWorkbook.Worksheets(2).Range("I1", Cells(k, 9)).FindNext(fnd)

受け取る変数が違うからかも知れません。
（シートの状況がわからないので検証してませんが）

もし既に確認済みならほっといて良いですよ。

この回答へのお礼

ありがとうございます！しかしfnd2をfndに直しても動かなかったので、原因自体は別だったようです…。

お礼日時：2017/06/06 20:47