Bom dia!!!

Imagine uma combinação e um critério emparelhado....o código foi projetado para eliminar duplicidades ai você me coloca 1, seria realmente uma boa linha de raciocínio ?

Não sei se resolve mas tente ai.

Sub test()
    Dim SL As Object, i As Long, ii As Long, temp, n As Long
    Dim myLimit As Long, w(), r As Range
    myLimit = Range("a1").Value
    Set SL = CreateObject("System.Collections.SortedList")
    With Range("y3").CurrentRegion
        For ii = 1 To .Columns.Count
            For i = 1 To .Rows.Count
                temp = .Cells(i, ii).Value
                If temp <> "" Then
                    If Not SL.contains(temp) Then
                        ReDim w(1)
                        Set w(0) = .Cells(i, ii)
                        w(1) = 1
                        SL(temp) = w
                    Else
                        w = SL(temp)
                        w(1) = w(1) + 1
                        Set w(0) = Union(w(0), .Cells(i, ii))
                        SL(temp) = w
                    End If
                End If
            Next
        Next
    End With
    For i = SL.Count - 1 To 0 Step -1
        w = SL.getbyindex(i)
        If w(1) > myLimit Then
            For Each r In w(0)
                n = n + 1
                r.ClearContents
                If n >= myLimit Then Exit For
            Next
        End If
    Next
    Set SL = Nothing
End Sub

Veja esse também deve te ajudar

Sub Macro2()
    
    'http://www.excelforum.com/excel-programming/826438-delete-values-in-range.html
    
    Dim rngCell As Range, _
        rngMyRange As Range
    Dim lngMyLimit As Long, _
        lngHighestDup As Long
    Dim dblMyNum As Double
    
    lngMyLimit = Range("a1").Value
    If lngMyLimit = 0 Then
       
        Exit Sub
    Else
        Set rngMyRange = Range("Y3:AA37")
    End If
    
    Application.ScreenUpdating = False
    
    For Each rngCell In rngMyRange
        If lngHighestDup = 0 Then
            lngHighestDup = Evaluate("COUNTIF(" & rngMyRange.Address & ",""=" & rngCell.Value & """)")
            dblMyNum = Val(rngCell)
        ElseIf Evaluate("COUNTIF(" & rngMyRange.Address & ",""=" & rngCell.Value & """)") > lngHighestDup Then
            lngHighestDup = Evaluate("COUNTIF(" & rngMyRange.Address & ",""=" & rngCell.Value & """)")
            dblMyNum = Val(rngCell)
        End If
    Next rngCell
    
    If lngHighestDup < lngMyLimit Then
       
        Set rngMyRange = Nothing
        Exit Sub
    Else
        For Each rngCell In rngMyRange
            If Val(rngCell) = dblMyNum Then
                rngCell.ClearContents
                lngLoopCount = lngLoopCount + 1
            End If
            If lngLoopCount = lngMyLimit Then
                Exit For
            End If
        Next rngCell
    End If
    
    Set rngMyRange = Nothing
    
    Application.ScreenUpdating = True
    
   
    
End Sub

Bom dia!!
Sendo satisfatório o resultado, então marque como resolvido!