VBA 列全体を別シートの列と比較し、同じ値がある行の、右端に値をコピーする方法について

お世話になっております。VBAで下記のようなものを作ろうとしましたが、わかりませんのでご教示願います。
①「sheet1」と「sheet2」があります。
②「sheet1」のC列に値が入っています。（複数行）
③「sheet2」のD列でその値を検索します。
④値があればその値のある行の一番右端のセルに、「sheet1」のD列にある値をコピーします。（検索した値の行の右端セル）
⑤それを「sheet1」のC列に値が入っているだけ繰り返し。
最終的に振り分けられた状態にしたいです。
マクロ初心者なのでソース頂けたら幸いです。
よろしくお願いいたします。

No.3 ベストアンサー 回答者： tom04 回答日時： 2018/09/13 16:21

No.１です。

何度もごめんなさい。
列を１列間違っていました。
Sheet2のC列とD列が違います。

前回のコードの
＞For i = 4 To .Cells(Rows.Count, "C").End(xlUp).Row
を
＞For i = 4 To .Cells(Rows.Count, "D").End(xlUp).Row
に
＞Set FoundCell = wS.Range("C:C").Find(what:=.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)
を
＞Set FoundCell = wS.Range("C:C").Find(what:=.Cells(i, "D"), LookIn:=xlValues, lookat:=xlWhole)
にそれぞれ変更してください。

どうも失礼しました。m(_ _)m

No.2 回答者： yoreyore 回答日時： 2018/09/13 12:15

画像が小さくて詳細がよく判らないのですが、おそらくこういうコトだと解釈して・・・

「Sheet1」は個別データのシートで、
　　C列4行目以降がデータで、設置？機材の型式とシリアルNo.が書かれている。
「Sheet２」は台帳のようなシートで、
　　型式毎に、設置使用済み？のシリアルNo.を整理記入する。
「Sheet1」は、数回新しい設置情報？に全面書き換えられて、書き換えられた後で、
その情報からをシリアルNo.を、「Sheet2」の台帳に追記する。

Sub Sample()
Dim i As Long, iend As Long, j As Long, jend As Long, ii As Long
Dim wS1 As Worksheet, wS2 As Worksheet
Dim MTD As Variant
Set wS1 = Worksheets("Sheet1") ' 新規 data sheet
Set wS2 = Worksheets("Sheet2") ' 台帳 sheet
iend = wS1.Cells(Rows.Count, "C").End(xlUp).Row
jend = wS2.Cells(Rows.Count, "D").End(xlUp).Row
ii = iend - 3
MTD = wS1.Range("C4:D" & iend)

With wS2 ' 台帳sheet
For j = 4 To jend
For i = 1 To ii
If .Cells(j, 4) = MTD(i, 1) Then
.Cells(j, Columns.Count).End(xlToLeft).Offset(, 1) = MTD(i, 2)
End If
Next
Next
End With
End Sub

この回答へのお礼

ご回答ありがとうございます。NO1の方のソースで動きましたので、今回はそちらを使わせていただきますが、yoreyoreさまのソースも活用させていきたいと思います。ありがとうございました。

お礼日時：2018/09/13 19:44

No.1 回答者： tom04 回答日時： 2018/09/13 09:05

こんにちは！

画像が小さくて詳細がよく判らないのですが、おそらくこういうコトだと解釈して・・・
「Sheet2」のC列4行目以降のデータが「Sheet1」のC列に存在すれば、
「Sheet1」のその行のD列データを「Sheet2」のD列以降右側に表示する！という解釈で・・・

というコトはSheet1に重複するデータが存在するのですかね？
関数でもできそうですが、VBAをご希望だというコトなので、一例です。
標準モジュールにしてください。

Sub Sample1()
　Dim i As Long, wS As Worksheet
　Dim FoundCell As Range, FirstCell As Range
　　Set wS = Worksheets("Sheet1")
　　　With Worksheets("Sheet2")
　　　　For i = 4 To .Cells(Rows.Count, "C").End(xlUp).Row
　　　　　Set FoundCell = wS.Range("C:C").Find(what:=.Cells(i, "C"), LookIn:=xlValues, lookat:=xlWhole)
　　　　　　If Not FoundCell Is Nothing Then
　　　　　　　Set FirstCell = FoundCell
　　　　　　　GoTo 処理
　　　　　　　Do
　　　　　　　　Set FoundCell = wS.Range("C:C").FindNext(after:=FoundCell)
　　　　　　　　If FoundCell.Address = FirstCell.Address Then Exit Do
　　　　　　　　GoTo 処理
　　　　　　　処理:
　　　　　　　　.Cells(i, Columns.Count).End(xlToLeft).Offset(, 1) = FoundCell.Offset(, 1)
　　　　　　　Loop
　　　　　　End If
　　　　Next i
　　　End With
End Sub

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