エクセルＶＢＡのＦＩＮＤの質問です。

質問

エクセルＶＢＡのＦＩＮＤの質問です。

シート１

　　　A　　　　B　　　　C　　　　　D
1 コード１ コード２ コード３ 名　称
2　　4　　　　1　　　　　1
3　　4　　　　2　　　　　2
4　　4　　　　3　　　　　1

シート２

　　　A　　　　B
1 コード１ 名　称
2　　1　　　名称１
3　　2　　　名称２

やりたいことは、シート１のＤ列に、シート１のコード３をもとにシート２から名称を取得したいのです。
下記に記したプログラムだと最初のＦＩＮＤＮＥＸＴは動くのですが、
2回目でエラーになってしまい、次を読んでくれません。
どなたか、ご教授頂けますでしょうか。
シート１の検索条件はコード１の"4"です。
シート１のコード１は重複キーで、一レコードずつ読んで行き、各レコード毎にシート２を読みたい
のです。
Dim シート1 As Worksheet
Dim シート2 As Worksheet
Dim obj As Object
Dim Lin As Integer
Dim mykey As Integer
Dim obj1 As Object
Dim Lin1 As Integer
Dim mykey1 As Integer
Dim st_Lin As Integer

Set シート1 = ThisWorkbook.Worksheets("シート１")
Lin = シート1.Cells(シート1.Rows.Count, 1).End(xlUp).Row
mykey = "4"
Set obj = シート1.Range("A1", "A" & Lin).Cells.Find(What:=mykey, _
LookIn:=xlValues, _
lookat:=xlWhole, _
SearchOrder:=xlByColumns)

If obj Is Nothing Then
　　MsgBox ("異常です")
　　Exit Sub
Else
　　st_Lin = obj.Row
　　Do Until obj.Row <> st_Lin
　　　Set obj = シート1.Range("A1", "A" & Lin).FindNext(obj)
　　　If obj Is Nothing Then
　　　　Exit Do
　　　Else
　　　　Set シート2 = ThisWorkbook.Worksheets("シート２")
　　　　　　With シート2
　　　　　　　　　Lin1 = .Cells(シート2.Rows.Count, 1).End(xlUp).Row
　　　　　　　　　mykey1 = シート1.Cells(obj.Row, 3).Value
　　　　　　　　　Set obj1 = .Range("A1", "A" & Lin1).Cells.Find
　　　　　　　　　(What:=mykey1,LookIn:=xlValues,lookat:=xlWhole,SearchOrder:=xlByColumns)
　　　　　　　　　If obj1 Is Nothing Then
　　　　　　　　　　MsgBox ("名称取得できませんでした")
　　　　　　　　　　Exit Sub
　　　　　　　　　Else
　　　　　　　　　　　シート1.Cells(obj.Row, 4).Value = .Cells(obj1.Row, 2).Value
　　　　　　　　　End If
　　　　　　End With
　　　End If
　　Loop
End If

回答No.1

watabe007 · ベストアンサー

参考に
Dim シート1 As Worksheet
Dim シート2 As Worksheet
Dim mykey As Integer
Dim obj As Range, c As Range

Set シート1 = ThisWorkbook.Worksheets("シート１")
Set シート2 = ThisWorkbook.Worksheets("シート２")
mykey = "4"
With シート1
　　For Each c In .Range("A2", .Cells(Rows.Count, "A").End(xlUp))
　　　　If c.Value = mykey Then
　　　　　　Set obj = シート2.Columns(1).Find(c.Offset(, 2), _
　　　　　　　　LookIn:=xlValues, _
　　　　　　　　lookat:=xlWhole, _
　　　　　　　　SearchOrder:=xlByColumns)
　　　　　　If Not obj Is Nothing Then
　　　　　　　　c.Offset(, 3).Value = obj.Offset(, 1).Value
　　　　　　Else
　　　　　　　　c.Offset(, 3).Value = "該当なし"
　　　　　　End If
　　　　End If
　　Next
End With

お礼

ＦＩＮＤＮＥＸＴを使わないんですね。
とっても参考になりました。ありがとうございました。

回答No.2

hige_082

FINDの勉強をしているなら、無視してください
FINDを使用しない例です
Sub test()
Dim シート1 As Worksheet
Dim シート2 As Worksheet
Dim i As Long
Dim j As Long
Set シート1 = Worksheets("シート１")
Set シート2 = Worksheets("シート２")
For i = 2 To シート1.Cells(Rows.Count, 3).End(xlUp).Row
For j = 2 To シート2.Cells(Rows.Count, 1).End(xlUp).Row
If シート1.Cells(i, 3).Value = シート2.Cells(j, 1).Value Then
シート1.Cells(i, 4).Value = シート2.Cells(j, 2).Value
Exit For
End If
Next j
If j > シート2.Cells(Rows.Count, 1).End(xlUp).Row Then MsgBox "名称取得できませんでした"
Next i
End Sub

こちらの方が簡単だと思います
参考まで

お礼

こんなやり方があるんですね。本当にありがとうございました。