id  field   date
1   a   1
1   b   1
1   d   1
1   a   2
1   s   2
1   d   2
2   a   3
2   d   3
2   b   4
2   s   4
1   w   1
1   q   1
1   b   2

a
d

b
s

id  field   date
1   a   1
1   b   1

id  field   date
1   a   1

id  field   date
1   a   1
1   d   1
1   a   2
1   d   2
2   a   3
2   d   3
2   b   4
2   s   4
1   w   1
1   q   1

Sub Manp()
Dim w1 As Range
Dim w2 As Range
Set w1 = Range("ww") 'named range of words to keep
Set w2 = Range("xx") 'named range of words to remove
O = Cells(Rows.Count, 1).End(xlUp).Row 'count number of records for specific id#
Application.ScreenUpdating = False

For i = 1 To w1.Rows.Count 'subset based on common fields, one to keep, one to remove
    Application.StatusBar = i
    v = Range(w1(i), w2(i))
    For Each j In [pp]
        Sheets("Sheet1").Select
        Selection.AutoFilter Field:=2, Criteria1:=v, Operator:=xlFilterValues 'filter by key fields
        Sheets("Sheet1").Range("$A$1:$C$15").AutoFilter Field:=1, Criteria1:=j ' filter by id#
        N3 = Cells(Rows.Count, 1).End(xlUp).Row
        If N3 > 1 Then
            Range("C2:C" & O).Copy Destination:=Sheets("Sheet4").Range("J1")
            Sheets("Sheet4").Select
            Columns(10).RemoveDuplicates Columns:=Array(1)
            N2 = Cells(Rows.Count, 10).End(xlUp).Row
            If N2 = 1 Then
                ddd = Range("J1:J" & N2 + 1).Value
                Else
                ddd = Range("J1:J" & N2).Value ' have unique list of days
            End If
            Columns(10).Clear
            Sheets("Sheet1").Select
             For Each k In ddd ' filter on each day
                Sheets("Sheet1").Select
                If Sheets("sheet1").AutoFilterMode Then Sheets("sheet1").ShowAllData
                Selection.AutoFilter Field:=2, Criteria1:=v, Operator:=xlFilterValues 'filter by key fields
                Sheets("Sheet1").Range("$A$1:$C$15").AutoFilter Field:=1, Criteria1:=j ' filter by id#
                Sheets("Sheet1").Range("$A$1:$C$15").AutoFilter Field:=3, Criteria1:=k
                 'check contents of cells
                Set visRng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible) ' Select only rows within the used range that are visible.
                Dim r As Range
                 Rowz = Sheets("Sheet1").AutoFilter.Range.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count - 1
                    If Rowz > 1 Then
                        r1 = 0
                        r2 = 0
                        For Each r In visRng.Rows ' Loop through each row in our visible range ...
                            If Cells(r.Row, 2) = w1(i) Then r1 = r.Row ' check if cell value is a keeper
                            If Cells(r.Row, 2) = w2(i) Then r2 = r.Row ' check if cell value is a discard wrt a keeper
                            If r1 > 0 And r2 > 0 Then Rows(r2).Delete ' check if both keeper and discard are in same subset
                        Next
                    End If
                Next k
            End If



        If Sheets("sheet1").AutoFilterMode Then Sheets("sheet1").ShowAllData
    Next j


Next i
Application.ScreenUpdating = True
End Sub

On Error Resume Next
Set visRng = ActiveSheet.UsedRange.SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If Not visRng Is Nothing Then

Sub RemoveValues()
    Dim listKeep As Object, listNoDups As Object, list As Object, key As Variant, Target As Range
    Dim data As Variant, results As Variant
    Dim r As Long, r2 As Long
    Dim flag As Boolean

    Set dicKeep = getRangeList("ww")
    Set dicNoDups = getRangeList("xx")

    Set list = CreateObject("System.Collections.ArrayList")

    With Worksheets("Sheet1")
        Set Target = .Range("A1", .Range("C" & .Rows.count).End(xlUp))
    End With

    data = Target.Value

    ReDim results(1 To UBound(data), 1 To UBound(data, 2))

    For r = 1 To UBound(data)
        key = data(r, 1) & "|" & data(r, 2) & "|" & data(r, 3)
        flag = False

        If Not list.Contains(data(r, 2)) Then
            flag = True
        ElseIf dicKeep.Contains(data(r, 2)) Then
            flag = True
        ElseIf Not dicNoDups.Contains(data(r, 2)) Then
            'Does this even matter???
        End If


        If flag Then
            r2 = r2 + 1
            results(r2, 1) = data(r, 1)
            results(r2, 2) = data(r, 2)
            results(r2, 3) = data(r, 3)
        End If

        If Not list.Contains(key) Then list.Add key
    Next
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Target.Value = results

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Function getRangeList(RangeName As String) As Object
    Dim list As Object, key As Variant
    Set list = CreateObject("System.Collections.ArrayList")

    For Each key In Range(RangeName).Value
        list.Add key
    Next

    Set getRangeList = list
End Function