Sub jjj()
Dim Rng As Range, i&, j&, arr, cnt&, ars As Range, rngDel As Range
    Set Rng = Me.Range("A1").CurrentRegion
    arr = ActiveWorkbook.Worksheets("Ëèñò2").Range("A1").CurrentRegion.Value
    Application.ScreenUpdating = 0
    For i = 1 To UBound(arr, 1)
        For j = 1 To UBound(arr, 2)
            Rng.AutoFilter Field:=1, Criteria1:= _
                "=*" & arr(i, j) & "*", Operator:=xlAnd
            cnt = 0
            Set rngDel = Nothing
            For Each ars In Rng.SpecialCells(xlCellTypeVisible).Areas
                cnt = cnt + 1
                If cnt = 2 Then
                    Set rngDel = ars
                ElseIf cnt > 2 Then
                    Set rngDel = Application.Union(rngDel, ars)
                End If
            Next ars
            If cnt > 1 Then rngDel.EntireRow.Delete
            Rng.AutoFilter Field:=1
        Next j
    Next i
    Application.ScreenUpdating = 1
End Sub