エクセルのマクロで検索機能を使いたいのですが

質問

お尋ねします。
エクセルのブックにsheet1とsheet2のシートがあります。
sheet1には、A1列料理名、B1列野菜、C1列和洋中の項目が入っており、値は、２行目から入っています。
sheet1のB列には、複数の野菜が入っている場合もあります。
sheet2には、A1列番号、B1列野菜（１種類しか入っていません）の項目があります。
sheet2の１行目は項目名で、２行目からA2が１、B2がナスというように
B2列は、十数行あり、sheet2のB行の野菜を選択し、sheet1のB列を検索し、ヒットすれば、D2にヒットした野菜を記入します。
それを繰り返し、sheet2の野菜名を選択し、sheet1の料理名に該当の野菜が含まれるかを記載したいのですが、マクロの記述をどのようにすればいいでしょうか？
よろしくお願いします。
sheet1
　A　　　　　　　　B 　　　 　C　　　　D　　　　E
ハンバーグ　　タマネギ　　　　　　洋　　　タマネギ
卵焼き　　　　　　　　　　　　　　和　　
ギョウザ　　　白菜、にんにく　　　中　　　白菜　　　にんにく

sheet2
A B
1 ナス
2 タマネギ
3 白菜
4 にんにく
5 キャベツ
6 人参

sheet1のD列から入っている野菜をD列、E列、F列とそれぞれ
野菜名を入れていきます。

すみませんが、お助けください。

回答No.1

zap35 · ベストアンサー

＞sheet2のB行の野菜を選択し、sheet1のB列を検索し、ヒットすれば、D2にヒットした野菜を記入します
とは「sheet1のB列の値にsheet2のB行に記入した材料があれば、Sheet1のD列から右方向に材料名を転記する」ということでよいですか

本当はSheet1のB列に記述された材料の順番でD列から右方向に展開したいのですが、Sheet1のB列の材料名の「区切り文字」が明示されていないので、Sheet2のB列に出現する順番で処理せざるを得ませんが承知おきください

マクロは以下です。標準モジュールシートに貼り付けてください
Sub Macro1()
Dim idx1, idx2, ptr As Integer
　For idx1 = 2 To Sheets("Sheet1").Range("A65536").End(xlUp).Row
　　Sheets("Sheet1").Cells(idx1, "D").Resize(1, 20).ClearContents
　　ptr = 4
　　For idx2 = 2 To Sheets("Sheet2").Range("B65536").End(xlUp).Row
　　　If InStr(Sheets("Sheet1").Cells(idx1, "B").Value, Sheets("sheet2").Cells(idx2, "B").Value) > 0 Then
　　　　Sheets("Sheet1").Cells(idx1, ptr).Value = Sheets("sheet2").Cells(idx2, "B").Value
　　　　ptr = ptr + 1
　　　End If
　　Next idx2
　Next idx1
End Sub

Sheet1のデータ
Ａ列　　　　　Ｂ列　　　　　　　Ｃ列
料理名　　　野菜　　　　　　　和洋中
ハンバーグ　タマネギ　　　　　洋
卵焼き　　　　卵　　　　　　　　　和
ギョウザ　　白菜、にんにく　　中

Sheet2のデータ
Ａ列　　Ｂ列
項番　　野菜
1　　　　ナス
2　　　　タマネギ
3　　　　白菜
4　　　　にんにく
5　　　　キャベツ
6　　　　人参
7　　　　卵

上記データに対して実行結果は以下になります
Sheet1のデータ
Ａ列　　　　　Ｂ列　　　　　　　Ｃ列　　　　　　Ｄ列　　　　　　Ｅ列
料理名　　　野菜　　　　　　　和洋中　　
ハンバーグ　タマネギ　　　　　洋　　　　　　タマネギ
卵焼き　　　　卵　　　　　　　　　和　　　　　　卵
ギョウザ　　白菜、にんにく　　中　　　　　　白菜　　　　　にんにく

お礼

早々にご教授頂きまして、ありがとうございます。
＞sheet2のB行の野菜を選択し、sheet1のB列を検索し、ヒットすれば、D2にヒットした野菜を記入します
とは「sheet1のB列の値にsheet2のB行に記入した材料があれば、Sheet1のD列から右方向に材料名を転記する」ということでよいですか
→そうしたいのです。

ＦＩＮＤを使った検索を考えていたのですが、
If InStr(Sheets("Sheet1").Cells(idx1, "B").Value, Sheets("sheet2").Cells(idx2, "B").Value) > 0 Then
　　　　Sheets("Sheet1").Cells(idx1, ptr).Value = Sheets("sheet2").Cells(idx2, "B").Value
の部分で、ヒットさせるのでしょうか？

回答No.2

redfox63

こんな感じでしょう

Sub Macro1()
　　Dim arSrc
　　Dim n As Integer
　　Dim oFind As Range, sAddress As String
　　Dim oTrgt As Range

　　' 検索データの取得
　　arSrc = Sheets("Sheet2").Range("A2").CurrentRegion
　　'転記先の消去
　　Sheets("Sheet1").Range("A1").CurrentRegion.Offset(0, 3).Clear

　　' 検索データのループ
　　For n = 2 To UBound(arSrc)
　　　　'検索対象の範囲 B列
　　　　With Sheets("Sheet1").Range("B:B")
　　　　　　' データを検索
　　　　　　Set oFind = .Find(arSrc(n, 2), LookIn:=xlValues)
　　　　　　If Not oFind Is Nothing Then
　　　　　　　　' 見つかった場合
　　　　　　　　' Doループ脱出条件を設定
　　　　　　　　sAddress = oFind.Address(0, 0)
　　　　　　　　Do
　　　　　　　　　　' 該当行の転記先を設定
　　　　　　　　　　Set oTrgt = oFind.End(xlToRight).Offset(0, 1)
　　　　　　　　　　oTrgt.Value = arSrc(n, 2)
　　　　　　　　　　' 他に該当行がないかをチェック
　　　　　　　　　　Set oFind = .FindNext(oFind)
　　　　　　　　Loop While Not oFind Is Nothing And oFind.Address(0, 0) <> sAddress
　　　　　　End If
　　　　End With
　　Next
End Sub

お礼

少し遅くなりましたが、どうもご丁寧にありがとうございました。