Enviar números únicos a una sola columna

[dragonfire33]

Buenas, tengo el siguiente código y lo q realiza es colorear la fuente del número único en rojo , pero me gustaría agregarle al código que además enviará a una sola columna esos números marcados en la columna Tb
Sub rojo()
Dim cl As New Collection
On Error GoTo hayrepe
Set RangoNums = Range("a1:sz42")
For Each Celda In RangoNums
K = CStr(Celda)
cl.Add Celda.Address, K
Celda.Font.color = 225 'si no exixte lo pone en rojo
repe:
Next
For Each CeldaR In RangoNums
If CeldaR.Font.color = 225 Then RR = RR + 1
Next
MsgBox "Hay " + Str(RR) + " elementos no repetidos"
Exit Sub
hayrepe:
Range(cl(K)).Font.color = 0 'si se repite lo vuelve a poner en negro
Resume repe
End Sub

 

[DanteAmor]

Algunas recomendaciones:

1. Utiliza la instrucción "Option Explicit" al inicio de tu código, de esta manera deberás declarar todas tus variables
2. Declara todas tus variables
3. No utilices las instrucciones On Error, podrás tener otros errores en el código y no te mostrará el problema.

Prueba con el siguiente código, deberá ser más rápido.

Sub rojo_DAM()
  Dim dic As Object
  Dim a As Variant, b As Variant, itm As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long
  Dim celda As String
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Range("A1:SZ42")
    a = .Value
    .Font.Color = 0
  End With

  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
  
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then n = Split(dic(a(i, j)), "|")(0) + 1 Else n = 1
        dic(a(i, j)) = n & "|" & i & "|" & j
      End If
    Next
  Next
  
  i = 0
  If dic.Count > 0 Then
    For Each ky In dic.keys
      If Split(dic(ky), "|")(0) = 1 Then
        i = i + 1
        b(i, 1) = ky
        Cells(CDbl(Split(dic(ky), "|")(1)), CDbl(Split(dic(ky), "|")(2))).Font.Color = 225
      End If
    Next
    Range("Tb1").Resize(UBound(b)).Value = b
    If i > 0 Then
      MsgBox "Hay " & i & " elementos no repetidos"
    Else
      MsgBox "No hay valores únicos"
    End If
  Else
    MsgBox "No hay celdas con valores"
  End If
End Sub

Saludos
Dante Amor

 

[dragonfire33]

hola dante buenos dias , cambie el rango de datos de "z1:ty42" y la colocacion de los numeros a la columna ua1
Puedes modificarlo ya que la ejecutarla me colorea menos números únicos y no los marca en rojo

 

[dragonfire33]

hola dante buenos dias , cambie el rango de datos de "z1:ty42" y la coocacion de los numeros a la columna ua1

 

[DanteAmor]

hola dante buenos dias , cambie el rango de datos de "z1:ty42" y la coocacion de los numeros a la columna ua1

Buenos días.
Y ya te funciona?

 

[dragonfire33]

No señor

 

[DanteAmor]

Puedes modificarlo ya que la ejecutarla me colorea menos números únicos y no los marca en rojo

Revisa que realmente sean únicos. Que no tengan espacios antes o después.
Si no funciona, pon una muestra de esos datos donde tienes un problema, para revisar esos datos.

Prueba así:

Sub rojo_DAM()
  Dim dic As Object
  Dim a As Variant, b As Variant, itm As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long
  Dim celda As String
  
  Set dic = CreateObject("Scripting.Dictionary")
  
  With Range("Z1:TY42")
    a = .Value
    .Font.Color = 0
  End With

  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
  
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then n = Split(dic(a(i, j)), "|")(0) + 1 Else n = 1
        dic(a(i, j)) = n & "|" & i & "|" & j
      End If
    Next
  Next
  
  i = 0
  If dic.Count > 0 Then
    For Each ky In dic.keys
      If Split(dic(ky), "|")(0) = 1 Then
        i = i + 1
        b(i, 1) = ky
        Cells(CDbl(Split(dic(ky), "|")(1)), CDbl(Split(dic(ky), "|")(2))).Font.Color = 225
      End If
    Next
    Range("UA1").Resize(UBound(b)).Value = b
    If i > 0 Then
      MsgBox "Hay " & i & " elementos no repetidos"
    Else
      MsgBox "No hay valores únicos"
    End If
  Else
    MsgBox "No hay celdas con valores"
  End If
End Sub

 

[DanteAmor]

Ajusté el número de columna. Ya que la primera versión empieza en la columna A, es la columna 1. Pero ahora empieza el rango en la columna Z, es la columna 26.

dic(a(i, j)) = n & "|" & i & "|" & j + 25

Utiliza la siguiente macro:

Sub rojo_DAM()
  Dim dic As Object
  Dim a As Variant, b As Variant, itm As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long
  Dim celda As String
 
  Set dic = CreateObject("Scripting.Dictionary")
 
  With Range("Z1:TY42")
    a = .Value
    .Font.Color = 0
  End With

  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
 
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then n = Split(dic(a(i, j)), "|")(0) + 1 Else n = 1
        dic(a(i, j)) = n & "|" & i & "|" & j + 25
      End If
    Next
  Next
 
  i = 0
  If dic.Count > 0 Then
    For Each ky In dic.keys
      If Split(dic(ky), "|")(0) = 1 Then
        i = i + 1
        b(i, 1) = ky
        Cells(CDbl(Split(dic(ky), "|")(1)), CDbl(Split(dic(ky), "|")(2))).Font.Color = 225
      End If
    Next
   
    Range("UA1").Resize(UBound(b)).Value = b
    If i > 0 Then
      MsgBox "Hay " & i & " elementos no repetidos"
    Else
      MsgBox "No hay valores únicos"
    End If
  Else
    MsgBox "No hay celdas con valores"
  End If
End Sub

 

[DanteAmor]

Hola de nuevo.
Agregué algunas líneas para que sea más rápida la macro:

Sub rojo_DAM()
  Dim dic As Object
  Dim a As Variant, b As Variant, itm As Variant, ky As Variant
  Dim i As Long, j As Long, n As Long
  Dim celda As String
  Dim rng As Range
  
  Application.ScreenUpdating = False
  Set dic = CreateObject("Scripting.Dictionary")
  Set rng = Range("A1")
  
  With Range("Z1:TY42")
    a = .Value
    .Font.Color = 0
  End With

  ReDim b(1 To UBound(a, 1) * UBound(a, 2), 1 To 1)
  
  For i = 1 To UBound(a, 1)
    For j = 1 To UBound(a, 2)
      If a(i, j) <> "" Then
        If dic.exists(a(i, j)) Then n = Split(dic(a(i, j)), "|")(0) + 1 Else n = 1
        dic(a(i, j)) = n & "|" & i & "|" & j + 25
      End If
    Next
  Next
  
  i = 0
  If dic.Count > 0 Then
    For Each ky In dic.keys
      If Split(dic(ky), "|")(0) = 1 Then
        i = i + 1
        b(i, 1) = ky
        Set rng = Union(rng, Cells(CDbl(Split(dic(ky), "|")(1)), CDbl(Split(dic(ky), "|")(2))))
      End If
    Next
    
    Range("UA1").Resize(UBound(b)).Value = b
    If i > 0 Then
      rng.Font.Color = 225
      Range("A1").Font.Color = 0
      MsgBox "Hay " & i & " elementos no repetidos"
    Else
      MsgBox "No hay valores únicos"
    End If
  Else
    MsgBox "No hay celdas con valores"
  End If
  Application.ScreenUpdating = True
End Sub

 

[dragonfire33]

Gracias maestro Dante funciona excelente