I sent this
Private Sub Worksheet_Change(ByVal Target As Range)
Application.ScreenUpdating = False
If Intersect(Target, Range("c2")) Is Nothing Then Exit Sub
'luv = Target
lr = Cells(Rows.Count, 1).End(xlUp).Row
lc = Cells(2, Columns.Count).End(xlToLeft).Column + 1
Range(Cells(2, "d"), Cells(2, lc)).EntireColumn.Delete
With Range("b1:b" & lr)
Set c = .Find(Target, LookIn:=xlValues, lookat:=xlWhole)
If Not c Is Nothing Then
firstAddress = c.Address
Do
lc = Cells(2, Columns.Count).End(xlToLeft).Column + 1
'MsgBox c.Row
Cells(c.Row, "a").Copy Cells(1, lc)
Cells(c.Row, "b").Offset(-2).Resize(5).Copy Cells(2, lc)
Cells(4, lc).Font.ColorIndex = 3
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With
Columns.AutoFit
ActiveSheet.PageSetup.PrintArea = Range(Cells(1, "d"), Cells(6, lc)).Address
Application.ScreenUpdating = True
End Sub