Sayın farez bey macroyu şu şekilde hallettim örnek dosyayı da buraya ekliyorum.

Sub Ara()
    Dim i As Byte
    For i = 2 To 6
        Cells(2, i).ClearContents
        If Cells(3, i) <> "" Then
            Cells(2, i) = "*" & Cells(3, i) & "*"
        End If
    Next i
    On Error Resume Next
    Range("B5").Select
    Selection.CurrentRegion.Select
    Selection.Clear
    Range("B5").Select
    Sheets("Veri").Columns("A:E").AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=Range("B1:F2"), CopyToRange:=Range("B5"), Unique:=False
    Range("F3").Select
End Sub