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