（エクセル）VBAで 検索して一致したセルの二つ左に入力するコードがわかりません。教えてください。

エクセルのVBAを使って、処理を行いたくてインターネットをいろいろ調べたのですが、目的の動作ができません。　助けてください。
sheet1には　　Ｃ列に品名が記入されています
A 列 　 B列 　 C列 　 D列
1 　 　 　　 みかん
2　　　　　　　　　　　　りんご
3　　　　　　　　　　　　すいか
4　　　　　　　　　　　　にんじん　　　　
5　　　　　　　　　　　　みかん
↓

sheet2には　　Ａ列に検索リスト　　　Ｂ列に　文字　　　　　　　　　　　　　　　
A 　　 B 　 C　　 D 　

1 りんご　　　林檎 　
2 みかん　　　蜜柑 　　　　　　　　　　　　　　　　　　　　　　　　　　　3 はくさい　　白菜　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　　4 れもん　　　檸檬　　　 　　　　　　　　　　　　　　　　　　　　　　5 にんじん　　人参 　

VBAを使って　　sheet1 に,　sheet2のリストを参照して　A1からA325に一致した場合は　
一致したセルの二つ左に　Ａ列の文字を入力したい
sheetの全てを検索対象として、置換　　二つ左に書く　　などやりたい事が複数になり難しくなりました。　　お助けください。

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

• ご指摘　　ありがとうございます。　　やってみました。宜しくお願いします。

  
  No.1の回答に寄せられた補足コメントです。 補足日時：2018/08/30 23:01

• sheet 2 です。　検索リストとして　　A1（りんご）をsheet 1 全域で検索し　一致したセルの二つ左に　B1（林檎）を入力　
  次にA2（みかん）をsheet 1 全域で検索し　一致したセルの二つ左に　B2（蜜柑）を入力・・・
  これを　sheet 2 A列　で空白セルになるまで実行する　　
  これが希望です。

  
    補足日時：2018/08/30 23:14

• こんな感じで　　sheet 1 に表示したいです。
  宜しく　　お願いいたします。

  
    補足日時：2018/08/30 23:19

No.1 回答者： tatsu99 回答日時： 2018/08/30 21:33

あなたが提示されたsheet1のセルのレイアウトは添付図のように見えます。

良くわからないので、画像で提示していただけませんでしょうか。
画面のイメージの切り取りは、snipping toolを使うと簡単にできます。（snipping toolはアクセサリに入っています）
この画像もsnipping toolで作成しました。
1回の投稿で1画像なので、sheet1とsheet2で2回の投稿が必要になります。

No.2 回答者： tatsu99 回答日時： 2018/08/30 23:07

提示されたのはsheet1でしょうか。

もし、そうなら、最初に提示されたC列に品名ではなく、D列に品名が正しいのでしょうか？

又、sheet2についても提示していただけませんでしょうか。

No.3 ベストアンサー 回答者： tatsu99 回答日時： 2018/08/30 23:55

以下のマクロを標準モジュールに登録してください。

sheet1のセルの名前がSheet2に該当名称がない場合は、なにも設定しません。
-----------------------------------------
Option Explicit
Public Sub 検索設定()
Dim dicT As Object
Dim row As Long
Dim col As Long
Dim maxrow As Long
Dim maxcol As Long
Dim sh1 As Worksheet
Dim sh2 As Worksheet
Dim key As Variant
Set sh1 = Worksheets("sheet1")
Set sh2 = Worksheets("sheet2")
Set dicT = CreateObject("Scripting.Dictionary")
maxrow = sh2.Cells(Rows.Count, "A").End(xlUp).row 'sheet2の最大行取得
'sheet2のひらがなと漢字の名前を記憶
For row = 1 To maxrow
key = sh2.Cells(row, "A").Value
dicT(key) = sh2.Cells(row, "B").Value
Next
sh1.Activate
'Sheet1の最終行、最終列を取得
ActiveCell.SpecialCells(xlLastCell).Select
maxrow = Selection.row
maxcol = Selection.Column
'1から最終行まで繰り返す
For row = 1 To maxrow
'３から最終列まで繰り返す
For col = 3 To maxcol
key = sh1.Cells(row, col).Value
'そのセルが空白でなく、Sheet2のA列に存在するなら
If key <> "" And dicT.exists(key) = True Then
'2列左にSheet2のB列の値を設定する
sh1.Cells(row, col - 2).Value = dicT(key)
End If
Next
Next
MsgBox ("完了")
End Sub

この回答へのお礼

早速の　作成　ありがとうございました。　いただいたVBAで　マニュアルの作成が楽に行えました。
ありがとうございます。

お礼日時：2018/08/31 21:08

No.4 回答者： tom04 回答日時： 2018/08/31 13:55

こんにちは！

横からお邪魔します。
標準モジュールにしてください。

Sub Sample1()
　Dim c As Range, r As Range, myRng As Range
　Dim FoundCell As Range, wS As Worksheet
　　Set wS = Worksheets("Sheet2")
　　With Worksheets("Sheet1")
　　　For Each c In .UsedRange
　　　　If c.Column > 2 And c <> "" Then
　　　　　If myRng Is Nothing Then
　　　　　　Set myRng = c
　　　　　Else
　　　　　　Set myRng = Union(myRng, c)
　　　　　End If
　　　　End If
　　　Next c
　　　For Each r In myRng
　　　　Set FoundCell = wS.Range("A:A").Find(what:=r, LookIn:=xlValues, lookat:=xlWhole)
　　　　　If Not FoundCell Is Nothing Then
　　　　　　r.Offset(, -2) = FoundCell.Offset(, 1)
　　　　　End If
　　　Next r
　　End With
End Sub

こんな感じではどうでしょうか？m(_ _)m

この回答へのお礼

作成　ありがとうございます。　こちらのVBAで　　希望する作業
（マニュアル作成）が簡略化できました。　　ありがとうございました。

お礼日時：2018/08/31 21:12