cercare dati

Sub cerca()
Dim r, r1, r2, c, c1, d, x, y, k, k1, rng

r = 6: c = 1
k = Cells(4, 1)
Range("A6:B2000").ClearContents
If k = "" Then Exit Sub
For x = 5 To 11 Step 3
  r2 = Cells(Rows.Count, x).End(xlUp).Row
  If r2 < 4 Then GoTo 2
  Set rng = Range(Cells(4, x), Cells(r2, x))
  For Each y In rng
    If y = "" Then GoTo 1
    r1 = y.Row: c1 = y.Column
    If Cells(r1, c1 - 1) <> "" Then k1 = Cells(r1, c1 - 1)
    If y Like "*" & k & "*" Then
      Cells(r, c) = y
      Cells(r, c + 1) = k1
      r = r + 1
    End If
1  Next y
2 Next x
Cells(1, 1).Select
End Sub