VBAで重複した値のセルに色付けをしたい

Sheet1に情報が入力されています(D列2行以下にシリアル)
検品作業でSheet2のB列4行以下にシリアルをスキャンして入力します
D列以降にSheet1の情報がコピーされるようにしてあります
下記のコードに追加してSheet2に入力したシリアルをみてSheet1の同じシリアルのセルに
色付けできませんでしょうか？


Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub

''「シリアル№」の行を検索する。
Dim iRow As Long
With Sheets("sheet1")
On Error Resume Next
iRow = 0
iRow = Application.WorksheetFunction.Match(Target.Value, .Range("D:D"), 0)
On Error GoTo 0
If iRow <= 0 Then Exit Sub

''対象行をコピーする。
Application.EnableEvents = False
.Range(.Cells(iRow, "E"), .Cells(iRow, "T")).Copy
Cells(Target.Row, "D").PasteSpecial Paste:=xlPasteValues
Application.EnableEvents = True
'カーソルの位置指定
ActiveCell.Offset(1, -2).Activate
End With
End Sub

No.1 ベストアンサー 回答者： tatsumaru77 回答日時： 2022/11/02 17:14

以下のようにしてください。

色は黄緑にしています。あなたの方で適切な色に設定して下さい。
With Sheets("sheet1")
・・・ここの最後の2行が追加した行
End With


--------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then Exit Sub
If Intersect(Target, Range("B:B")) Is Nothing Then Exit Sub

''「シリアル№」の行を検索する。
Dim iRow As Long
With Sheets("sheet1")
On Error Resume Next
iRow = 0
iRow = Application.WorksheetFunction.Match(Target.Value, .Range("D:D"), 0)
On Error GoTo 0
If iRow <= 0 Then Exit Sub

''対象行をコピーする。
Application.EnableEvents = False
.Range(.Cells(iRow, "E"), .Cells(iRow, "T")).Copy
Cells(Target.Row, "D").PasteSpecial Paste:=xlPasteValues
Application.EnableEvents = True
'カーソルの位置指定
ActiveCell.Offset(1, -2).Activate
'Sheet1の該当セルに色をつける
.Cells(iRow, "D").Interior.Color = 5296274 '黄緑
End With
End Sub

この回答へのお礼

助かりました、ありがとうございました！m(__)m

お礼日時：2022/11/02 17:28