こんにちはゲストさん。会員登録(無料)して質問・回答してみよう!

解決済みの質問

エクセルVBAのFINDの質問です。

エクセルVBAのFINDの質問です。

シート1

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

シート2

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

やりたいことは、シート1のD列に、シート1のコード3をもとにシート2から名称を取得したいのです。
下記に記したプログラムだと最初のFINDNEXTは動くのですが、
2回目でエラーになってしまい、次を読んでくれません。
どなたか、ご教授頂けますでしょうか。
シート1の検索条件はコード1の"4"です。
シート1のコード1は重複キーで、一レコードずつ読んで行き、各レコード毎にシート2を読みたい
のです。
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("シート1")
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("シート2")
      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

投稿日時 - 2010-02-15 16:15:43

QNo.5678881

すぐに回答ほしいです

質問者が選んだベストアンサー

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

Set シート1 = ThisWorkbook.Worksheets("シート1")
Set シート2 = ThisWorkbook.Worksheets("シート2")
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

投稿日時 - 2010-02-15 17:12:54

お礼

FINDNEXTを使わないんですね。
とっても参考になりました。ありがとうございました。

投稿日時 - 2010-02-15 21:36:55

このQ&Aは役に立ちましたか?

4人が「このQ&Aが役に立った」と投票しています

回答(2)

ANo.2

FINDの勉強をしているなら、無視してください
FINDを使用しない例です
Sub test()
Dim シート1 As Worksheet
Dim シート2 As Worksheet
Dim i As Long
Dim j As Long
Set シート1 = Worksheets("シート1")
Set シート2 = Worksheets("シート2")
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

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

投稿日時 - 2010-02-15 19:21:33

お礼

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

投稿日時 - 2010-02-15 21:35:30

あなたにオススメの質問