値がシート間で一致した場合の処理（大量）

以下のコードはブック内のSheets(1)のD2セルにある値がSheets(2)のG列のセルに部分一致で
存在する場合
G列の当該セルからオフセットしたC列の値をSheets(1)のD2セルの1つ隣のC2セルに貼り付けるものです。

Sub 検索して貼付け()

Dim FoundCell As Range
Set FoundCell = Sheets(2).Range("G1").CurrentRegion.Find(What:=Sheets(1).Range("D2").Value, LookAt:=xlPart)

Sheets(2).Activate
Sheets(2).Range(FoundCell.Address).Offset(0, -4).Select
ActiveCell.Copy _
Destination:=Sheets(1).Range("C2")

Sheets(1).Activate

End Sub


Sheets(1),Sheets(2)にそれぞれ同じフォーマットで5000行以上のデータがあった場合、1行分づつこのコードを作るのはしんどいです。
一度に処理できるようにコードをまとめられませんでしょうか？

お詳しい方宜しくお願い致します。

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

• ご質問ありがとうございます。
  ２回目以降はそのように繰り返します。

  No.2の回答に寄せられた補足コメントです。 補足日時：2022/01/30 05:37

No.1 ベストアンサー 回答者： fujillin 回答日時： 2022/01/29 20:26

こんばんは

Sheet(1)のD列でループさせればよいだけですが、ご質問文の文章とコードに異なる点が・・

文章では「G列のセルに部分一致で」となっていますが、コードは Range("G1").CurrentRegion となっているので一致していません。
文章の方を、正と解釈しました。
また、ご提示のコードではコピペを行っていますが、以下のサンプルでは「値の転記」に変えてありますので、書式等はコピーされません。
（書式等も必要な場合は、コピペに修正してください）

以下、ご参考までに。

Sub Q12780908()
Dim rw, fc, v, s

With Worksheets(1)
For rw = 2 To .Cells(Rows.Count, 4).End(xlUp).Row
s = .Cells(rw, 4).Value
Set fc = Worksheets(2).Columns(7).Find(what:=s, LookAt:=xlPart)
If s = "" Or fc Is Nothing Then v = "" Else v = fc.Offset(, -4).Value
.Cells(rw, 3).Value = v
Next rw
End With
End Sub

この回答へのお礼

理想の形になりました。
ありがとうございました❗

お礼日時：2022/01/31 15:02

No.3 回答者： tatsumaru77 回答日時： 2022/01/30 07:22

No2です。

No1の方が、質問者様の希望通りの回答をされてますので、回答を控えます。

この回答へのお礼

ありがとうございました❗

お礼日時：2022/01/31 15:01

No.2 回答者： tatsumaru77 回答日時： 2022/01/29 20:31

次の繰り返しは、どのように繰り返すのですか。

2回目は、
Sheets(1)のD３セルにある値がSheets(2)のG列のセルに部分一致で
存在する場合
G列の当該セルからオフセットしたC列の値をSheets(1)のD３セルの1つ隣のC３セルに貼り付ければ良いのですか。

検索元データ　　　　　　検索先　　　　　貼り付けデータ　　貼り付け先
２回目　Sheet(1)のD3　　1回目と同じ　　１回目と同じ　　　Sheet(1)のC3
３回目　Sheet(1)のD4　　1回目と同じ　　１回目と同じ　　　Sheet(1)のC4
・・
ｎ回目　Sheet(1)のDx　1回目と同じ　　１回目と同じ　　　　Sheet(1)のCx　（x=n+1）