• 👏 Bienvenido a nuestra comunidad Excel

    ¿Todavía no estás registrado? 😲

    Registrate gratis aquí y podrás:

    💪 Hacer preguntas a los expertos
    ⬇️ Descargar ejemplos y plantillas
    🏅 
    Acceder a contenidos premium

modificar formula para dejar un solo numero repetido

jhon6666

Member
buenas maestros como puedo modificar esta formula para que al eliminar los repetidos me deje un numero de esos
me explico si el numero se repite 2, 3 , 4, 5 .....veces me deje solamente un numero de esos que se repiten
gracias
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
 

Adjuntos

Guillermo Hm

Active member
buenas maestros como puedo modificar esta formula para que al eliminar los repetidos me deje un numero de esos
me explico si el numero se repite 2, 3 , 4, 5 .....veces me deje solamente un numero de esos que se repiten
gracias
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
Hola,

Si lo que quieres es eliminar los duplicados, puedes grabar una macro haciendo uso del comando datos/quitar duplicados..
 

jhon6666

Member
no la cuestion es dejar un numero de esos repetidos digamos que si el numero se repite catorce veces dejarme uno solo de ellos
 

jhon6666

Member
no la idea es que aquellos numeros que se repiten asi sea dos veces me deje un solo numero de ellos
los valores unicos no se tocan
 

Cacho R

Well-known member
no la idea es que aquellos numeros que se repiten asi sea dos veces me deje un solo numero de ellos los valores unicos no se tocan
Hola! jhon (y Guillermo)
Al igual que en tu consulta anterior: ¿No es -acaso- mejor entregarte en una columna a la derecha del rango de datos esos números únicos?...
 

jhon6666

Member
la idea es dejar un duplicado como lo dijo el maestro guillermo pero en su lugar de celda
por ejemplo si el numero duplicado se encuenta en c10 pero tambien esta en d15 se dejaria el numero del c10 ya que fue la primera vez que se encontro y el numero que esta en d15 se eliminaria
 

Cacho R

Well-known member
... la idea es dejar un duplicado como lo dijo el maestro guillermo pero en su lugar de celda.
Por ejemplo así:
JavaScript:
Sub eliminar_Duplicados()
Dim Mat, Q%, i%, R%, j%, Dic, Rng As Range, iKey$
'-------------------\
'by Cacho Rodríguez ||
'-------------------/
Mat = [a1].CurrentRegion: Q = UBound(Mat): R = UBound(Mat, 2)
Set Dic = CreateObject("Scripting.Dictionary")

For i = 1 To Q
  For j = 1 To R
    iKey = Mat(i, j)
    If iKey <> Empty Then
      If Dic.Exists(iKey) Then Mat(i, j) = Empty Else Dic(iKey) = Empty
    End If
  Next
Next
With [a1].Resize(Q, R)
  .NumberFormat = "@"
  .Value = Mat
End With
End
End Sub
 

Antoni

Well-known member
Lo mismo que Cacho 😘, pero por el cuento de la vieja. :) 😷:
Código:
Sub EliminarDuplicados()
Dim x As Long
Application.ScreenUpdating = False
Range("AAA:AAC").ClearContents
For Each celda In Range("A1:SX42")
   If Not Trim(celda) = "" Then
      x = x + 1
      Range("AAA" & x) = celda
      Range("AAB" & x) = x
      Range("AAC" & x) = celda.Address
   End If
Next
Range("AAA1:AAC" & x).Sort key1:=Columns("AAA"), key2:=Columns("AAB"), Header:=xlNo
For x = x To 2 Step -1
   If Range("AAA" & x) = Range("AAA" & x - 1) Then
      Range(Range("AAC" & x)) = ""
   End If
Next
Range("AAA:AAC").Delete
End Sub
 
Arriba