【VBA】2つのシートの値を比較して条件一致したら、同じ行の隣の値を別ブックへ転記したいです。 VB

【VBA】2つのシートの値を比較して条件一致したら、同じ行の隣の値を別ブックへ転記したいです。

VBA初心者です。
現在契約書を作成しており、エクセルにまとめた顧客データを契約書フォーマットへ転記する作業をVBAで行いたいと思っているのですが、どうしてもデバッグを解消できない項目があり、質問させてください。

顧客データが2シートあり、それぞれ別の顧客データが並んでいます。軸とするデータ、sheet1のC列の値（No.）とsheet2のB列の値（No.）を比較し、sheet2のB列に同じ値があればその横のC列の値（商品名）をブック2（契約書）のD11に転記したいです。

また、sheet1のC列の値がsheet2のＢ列に存在しない時は、Book2のD11には"ー"が表示されるようにしたいです。

尚、契約書は顧客ごとに作成、PDFの作成まで自動化する予定で構築しており、No.を軸とした検索から商品名の転記までをループ化したいです。

どのようなVBAを記述すれば実現可能かご教示いただけますでしょうか。
宜しくお願い致します。

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2021/10/07 13:50

こんにちは、

なんか、条件などおかしいのですけれど
まあ、構築中のサンプルとして、、、コードを書きましたので
参考になればと思います。
Book2の画像ではC列となっていますのでC列12行より
（複数商品がヒットした場合を想定）
下に商品名、D列12行目より下に№を出力します
出来るだけ纏めておきましたので、必要に応じて変更してください。

.Cells(12 + n, "C").Resize(, 2).Value = getRng.Resize(, 2).Value
みたいにも書けるかと思いますが、順番がsheet2の順番になるので
分けています。
抜出順位は顧客データsheet1の順位となります

取敢えず、Book2は開いている事

Sub test()
Dim 顧客データBK As Workbook, 契約書BK As Workbook
Dim cRng As Range, bRng As Range
Dim getRng As Range, r As Range
Dim n As Long
Set 顧客データBK = ThisWorkbook
Set 契約書BK = Workbooks("Book2.xlsx")

With 顧客データBK
Set cRng = .Worksheets("sheet1").Range("C2", .Worksheets("sheet1").Cells(Rows.Count, "C").End(xlUp))
Set bRng = .Worksheets("sheet2").Range("B2", .Worksheets("sheet2").Cells(Rows.Count, "B").End(xlUp))
End With

n = 0
For Each r In cRng
Set getRng = bRng.Find(What:=r.Text, LookIn:=xlValues, LookAt:=xlWhole)
If Not getRng Is Nothing Then
With 契約書BK.Worksheets("sheet1")
.Cells(12 + n, "C").Value = getRng.Offset(, 1).Value
.Cells(12 + n, "D").Value = getRng.Value
End With
n = n + 1
End If
Next
End Sub