Excel VBA 条件検索による文字の抽出 教えてください シート3のB4に入力されたワードを シ

Excel　VBA 　条件検索による文字の抽出

教えてください

シート3のB4に入力されたワードを
シート2のA:Aから探しに行く
ワードが一致したら一致しなくなるまで
横のセルを全て抽出し、
シート3のD4より抽出したデータを入力していくというマクロを組みたいのですが
自分でプログラムまで組んでみたのですが検索して横のセルを抽出をまで何とかいったのですがここからどうしてもできません　
アドバイスいただけないでしょうか
※検索したいエクセルファイルを添付しました　左側がシート3 右側がシート2です

sub sample()
Dim　Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim a As Range
Dim b As Range
Set Ws2=worksheets("sheet2")
Set Ws3=worksheets("sheet3")
Set a=Ws2.Range("A:A").Find(what:=Ws3("B4").value,lookat=xlwhole
If Not a Is Nothing Then
Ws3.Range("D4").value=a.offset(0,1).value
End if
End sub
以上　よろしくお願いします

質問者からの補足コメント

• 画像文字化けしてましたすいません

  
    補足日時：2017/06/28 18:32

No.1 ベストアンサー 回答者： tom04 回答日時： 2017/06/28 19:33

こんばんは！

お示しの画像では詳細が判らないのですが・・・

Sub Sample1()
Dim cnt As Long, lastCol As Long, wS As Worksheet
Dim myFound As Range, myFirst As Range
Set wS = Worksheets("Sheet3")
cnt = 3
With Worksheets("Sheet2")
lastCol = .Cells(3, Columns.Count).End(xlToLeft).Column '//←3行目で最終列取得//
Set myFound = .Range("A:A").Find(what:=wS.Range("B4"), LookIn:=xlValues, lookat:=xlWhole)
If Not myFound Is Nothing Then
Set myFirst = myFound
GoTo 処理
Do
Set myFound = .Range("A:A").FindNext(after:=myFound)
If myFound.Address = myFirst.Address Then Exit Do
GoTo 処理
処理:
cnt = cnt + 1
wS.Cells(cnt, "D").Resize(, lastCol - 1).Value = myFound.Offset(, 1).Resize(, lastCol - 1).Value
Loop
Else
MsgBox "該当データなし"
End If
End With
End Sub

こんな感じをお望みなのでしょうか？m(_ _)m

この回答へのお礼

うまくプログラム動きましたありがとうございました

お礼日時：2017/06/29 18:09