Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [B2]) Is Nothing Then
Dim Sh As Worksheet, Rng As Range, sRng As Range
Dim MyAdd As String: Dim MyColor As Byte
Set Sh = Sheets("Data"): Set Rng = Sh.Range(Sh.[B2], Sh.[B65500].End(xlUp))
With [B2].Interior
If .ColorIndex < 30 Then MyColor = 35 Else MyColor = .ColorIndex + 1
End With
[B2].CurrentRegion.Offset(2).ClearContents
Set sRng = Rng.Find(Target.Value, , xlFormulas, xlWhole)
If Not sRng Is Nothing Then
MyAdd = sRng.Address
Do
With [A65500].End(xlUp).Offset(1)
.Resize(, 3).Value = sRng.Offset(, -1).Resize(, 3).Value
End With
Set sRng = Rng.FindNext(sRng)
Loop While Not sRng Is Nothing And sRng.Address <> MyAdd
End If
End If
[B2].Interior.ColorIndex = MyColor
End Sub