Enviar números únicos a una sola columna

D

dragonfire33

Board Regular
Joined
Oct 7, 2021
Messages
90
Office Version
  1. 365
Platform
  1. Windows
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
 

Excel Facts

Using Function Arguments with nested formulas
If writing INDEX in Func. Arguments, type MATCH(. Use the mouse to click inside MATCH in the formula bar. Dialog switches to MATCH.
Sort by date Sort by votes
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.

VBA Code: 
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
 
Upvote 0
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
 
Upvote 0
hola dante buenos dias , cambie el rango de datos de "z1:ty42" y la coocacion de los numeros a la columna ua1
 
Upvote 0
dragonfire33 said:
Puedes modificarlo ya que la ejecutarla me colorea menos números únicos y no los marca en rojo
Click to expand...
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í:
Excel Formula: 
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
 
Upvote 0
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.

Rich (BB code): 
dic(a(i, j)) = n & "|" & i & "|" & j + 25

Utiliza la siguiente macro:

VBA Code: 
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

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

VBA Code: 
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


😇
 
Upvote 0
Solution
You must log in or register to reply here.

Similar threads

D
  • Question
Enviar a una columna los números únicos de acuerdo a un rango de datos
Replies
1
Views
195
Joe4
Joe4
D
  • Question
modificar codigo para resaltar en 3 celdas en linea
2
Replies
15
Views
547
DanteAmor
DanteAmor
Y
  • Question
Pegar una lista de valores sólo en celdas visibles
Replies
1
Views
3K
DanteAmor
DanteAmor
L
  • Question
Enviar datos específicos de una hoja a otra al cumplir una condición
Replies
0
Views
156
leobrice
L
D
  • Solved
modificar codigo para que se ejecute en otra columna
Replies
2
Views
679
dragonfire33
D

Forum statistics

Threads
1,220,965
Messages
6,157,120
Members
451,399
Latest member
alchavar

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top