dejar un solo numero de los que se repiten

como puedo modificar este codigo para que me deje un numero de los que se repiten

Sub Eliminar_repetidos()
Dim Mat, Q%, i%, R%, j%, Dic, Rng As Range, Valor, iniTime!
iniTime = Timer
Set Dic = CreateObject("Scripting.Dictionary")
Mat = Range("A1:SX42"): Q = UBound(Mat): R = UBound(Mat, 2)

For i = 1 To Q
  For j = 1 To R
    Valor = Mat(i, j)
    If Valor <> Empty Then
      Select Case Dic.Exists(Valor)
        Case True
          Set Rng = Union(Dic(Valor), Cells(i, j))
        Case False
          Set Rng = Cells(i, j)
      End Select
      Set Dic(Valor) = Rng
    End If
  Next
Next

Application.ScreenUpdating = False
For Each Valor In Dic.Keys
  If Dic(Valor).Count > 10 Then Dic(Valor).ClearContents
Next
Application.ScreenUpdating = True

MsgBox "Proceso terminado en " & Round(Timer - iniTime, 3) & " seg."
End Sub