Sub LotFilter()
Dim RngDelete As Range
Application.ScreenUpdating = False
For Each rw In Range("H1:M3").Rows
  ReDim matches(1 To 1)
  For Each rowe In Range("A2:F12").Rows
    x = Evaluate("SUMPRODUCT(COUNTIF(" & rw.Address & "," & rowe.Address & "))")
    If x > 3 Then
      If RngDelete Is Nothing Then
        Set RngDelete = rowe
      Else
        Set RngDelete = Union(RngDelete, rowe)
      End If
    End If
  Next rowe
Next rw
If Not RngDelete Is Nothing Then
 ' RngDelete.Select  'or one of the 2 lines below:
 'RngDelete.Delete Shift:=xlUp
 RngDelete.EntireRow.Delete
End If
Application.ScreenUpdating = True
End Sub