新生活を充実させるための「こだわり」を取材!!

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

教えて!goo グレード

A 回答 (3件)

こんにちは。



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

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

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

こんにちは



すでに指摘がありますが、うまくいかない原因になりそうなのは、
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
    • good
    • 0
この回答へのお礼

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

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

ヘルプより


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)

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

もし既に確認済みならほっといて良いですよ。
    • good
    • 0
この回答へのお礼

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

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

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

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

教えて!goo グレード

このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング