=CERCA.VERT(B4;SCEGLI({1;2;3;4;5};Farmaci!B3:B10;Farmaci!C3:C10;Farmaci!D3:D10;Farmaci!E3:E10;Farmaci!F3:F10;);5;0)

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Double
Dim lr As Long
Dim ur As Long
Dim rng As Range
Dim cel As Range
If Not Intersect(Target, Range("a4")) Is Nothing Then
lr = Worksheets("Farmaci").Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Worksheets("Farmaci").Range("b2:b" & lr)
Range("a10:f1000").ClearContents
For Each cel In rng
ur = Worksheets("Ricerca").Cells(Rows.Count, 1).End(xlUp).Row
lr = Worksheets("Farmaci").Cells(Rows.Count, 1).End(xlUp).Row
    If cel.Value = Range("a4").Value Then
        Cells(ur + 1, 1) = cel.Offset(0, -1).Value
        Cells(ur + 1, 2) = cel.Value
        Cells(ur + 1, 3) = cel.Offset(0, 1).Value
        Cells(ur + 1, 4) = cel.Offset(0, 2).Value
        Cells(ur + 1, 5) = cel.Offset(0, 3).Value
        Cells(ur + 1, 6) = cel.Offset(0, 4).Value
        ur = ur + 1
    End If
Next cel
End If
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Dim ur As Long
  Dim rng As Range
  Dim cella As Range
  If Target.Address(0, 0) = "A4" Then
    With Worksheets("Farmaci")
      Set rng = Intersect(.UsedRange, .Columns(2))
    End With
    With Me
      Application.EnableEvents = False
      .Range("A10:F" & .Cells.SpecialCells(xlCellTypeLastCell).Row + 1).ClearContents
      ur = 10
      For Each cella In rng
        If cella.Value = Target.Value Then
          .Cells(ur, 1).Resize(1, 6).Value = cella.Offset(0, -1).Resize(1, 6).Value
          ur = ur + 1
        End If
      Next cella
      Application.EnableEvents = True
    End With
    Set rng = Nothing
  End If
End Sub