Como realizar coloreo a números repetidos en secuencia
Como puedo colorear aquellos números que están repetidos en línea y además pintar en rojo aquellos números mayores de 10 en color rojo
1 Respuesta
ojala fuera macro la de amarillo y la de rojo
Los números pintado en amarillo debe ser repetido pero en inversa digamos pintar el 324 o 423 o 432 el mismo numero pero invertido gracias
debe ser como se muestra en la imagen
Te paso la macro para colorear los amarillos y también los rojos.
Entendiendo que los datos empiezan en la celda C1 y terminan en la columna AD. Que los datos de 3 números están en 3 columnas, separados por 2 columnas, luego 3 columnas y así sucesivamente, como se puede apreciar en la siguiente imagen:
Pueden crecer los datos hacia abajo. También pueden crecer los datos hacia la derecha, solamente ajusta la última columna en estas líneas:
lr = Range("C:AD").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
Set rng = Range("C1:AD" & lr)Pero si cambias de posición el dato inicial C1, entonces hay que realizar algunos ajustes en la macro.
Prueba y me comentas:
Sub colorearnumeros_2()
'Por Dante Amor
Dim a As Variant, b As Variant, ky As Variant
Dim i As Long, j As Long, k As Long, lr As Long
Dim n As Long, m As Long, x As Long, y As Long
Dim coltot As Long, fil As Long, col As Long
Dim cad As String, coordenada As String
Dim dic As Object
Dim rng As Range, rngAma As Range, rngRojo As Range
'
lr = Range("C:AD").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
Set rng = Range("C1:AD" & lr)
Set dic = CreateObject("Scripting.Dictionary")
rng.Interior.Color = xlNone
a = rng.Value
coltot = Int(rng.Columns.Count / 5) + 1
'
ReDim b(1 To UBound(a, 1) * coltot, 1 To UBound(a, 2) * coltot)
'
'Almacena en un diccionario todos los números de tres en tres
For j = 1 To UBound(a, 2) Step 5
For i = 1 To UBound(a, 1)
If a(i, j) <> "" Then
If a(i, j) > 10 Then _
If rngRojo Is Nothing Then Set rngRojo = Cells(i, j + 2) Else Set rngRojo = Union(rngRojo, Cells(i, j + 2))
If a(i, j + 1) > 10 Then _
If rngRojo Is Nothing Then Set rngRojo = Cells(i, j + 2 + 1) Else Set rngRojo = Union(rngRojo, Cells(i, j + 2 + 1))
If a(i, j + 2) > 10 Then _
If rngRojo Is Nothing Then Set rngRojo = Cells(i, j + 2 + 2) Else Set rngRojo = Union(rngRojo, Cells(i, j + 2 + 2))
'
cad = a(i, j) & "|" & a(i, j + 1) & "|" & a(i, j + 2)
If Not dic.exists(cad) Then
y = y + 1
dic(cad) = 1 & "|" & y & "|" & 1
Else
x = Split(dic(cad), "|")(0)
n = Split(dic(cad), "|")(1)
m = Split(dic(cad), "|")(2)
x = x + 1
dic(cad) = x & "|" & n & "|" & m
End If
x = Split(dic(cad), "|")(0)
n = Split(dic(cad), "|")(1)
m = Split(dic(cad), "|")(2)
'Alamcena en la matriz 'b' todas las coordenas (fila, columna) de los números
b(n, m) = i & "|" & j
m = m + 1
dic(cad) = x & "|" & n & "|" & m
End If
Next
Next
'
'Revisa cuáles números (de 3) tienen duplicados
For Each ky In dic.keys
x = Split(dic(ky), "|")(0)
If x > 1 Then
'si tiene duplicado, obtiene los datos del diccionario
n = Split(dic(ky), "|")(1)
m = Split(dic(ky), "|")(2) - 1
For j = 1 To m
'obtiene las coordenas de la matriz 'b' de las celdas a colorear
coordenada = b(n, j)
fil = Split(coordenada, "|")(0)
col = Split(coordenada, "|")(1) + 2
If rngAma Is Nothing Then
Set rngAma = Cells(fil, col).Resize(1, 3)
Else
Set rngAma = Union(rngAma, Cells(fil, col).Resize(1, 3))
End If
Next
End If
Next
'colorea las celdas
If Not rngAma Is Nothing Then rngAma.Interior.Color = vbYellow
If Not rngRojo Is Nothing Then rngRojo.Interior.Color = vbRed
End Sub
Los números pintado en amarillo debe ser repetido pero en inversa digamos pintar el 324 o 423 o 432 el mismo numero pero invertido gracias
Estas son nuevas reglas. Además la posición de los números en la segunda imagen no coincide con la posición de la primera imagen.
Tendrá que ser otra macro, ya que las reglas cambiaron.
¡Gracias! dante
Dante el código funciona perfectamente(el rango del código es el indicado) pero como puedo para que se ejecute en filas intermedias digamos que se ejecute en la fila 2, 4,6,8, hata la fila 200
Dante como puedo modificar el código para que se ejecute en filas intermedias
O sea desde la fila 2 a la fila 200 con la condición de numero invertido en amarillo y en la fila 3,5,7 hasta fila 201 con la condición de numero mayor que 10 en color rojo
Para que empiece en la fila 2, 4, 6 etc, hasta la última fila, cambia esta línea:
For i = 1 To UBound(a, 1)
Por esta:
For i = 2 To UBound(a, 1) step 2
Lo del color Rojo ya lo hace.
Lo del número invertido, quieres todas las combinaciones de 3 números:
1,2,3
1,3,2
2,1,3
2,3,1
3,1,2
3,2,1
Comentas...
Perfecto la condición del numero invertido, ahora solo falta colorear en rojo los números mayores de 10 en fila 3, 5,7,9, hasta 201
Que línea elimino para que no se marque la condición de color máximo en rojo del código y modificar este código para ejecutarlo aparte
sub color
dim celda as range
for each celda in sheets("hoja1").usedrange
if celda.value >10 then celda.interior.color = vbred
next celda
end sub
pero a partir de la fila 3 hasta la fila 201 en filas intermedias
Más despacio, porque no te estoy entendiendo.
¿Los colores rojos solamente deben revisarse en las filas 3,5,7 etc?
¿Cuáles son los números invertidos que se deben revisar?
Exacto los colores rojos en fila 3,5 7, hasta 201 valores mayores a 10
El código de invertido funciona muy bien solo hacerle esa modificación
El código de invertido funciona muy bien solo hacerle esa modificación
No entiendo a qué te refieres con "código invertido"
¿Qué modificación necesitas?
Te expliqué, pero me parece que hay una confusión.
La combinación de 3 dígitos, por ejemplo: 1,2 y 3 tiene como resultado 6 combinaciones:
1,2,3
1,3,2
2,1,3
2,3,1
3,1,2
3,2,1
¿Quieres que la macro revise todas las combinaciones posibles de cada código?
Eso no estaba en tu pregunta original.
Te anexo el código para pintar el color rojo.
Sub colorearnumeros_2()
'Por Dante Amor
Dim a As Variant, b As Variant, ky As Variant
Dim i As Long, j As Long, k As Long, lr As Long
Dim n As Long, m As Long, x As Long, y As Long, cTot As Long
Dim cad As String, coordenada As String
Dim dic As Object
Dim rng As Range, rngAma As Range, rngRoj As Range
'
lr = Range("C:AD").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
Set rng = Range("C1:AD" & lr)
Set dic = CreateObject("Scripting.Dictionary")
rng.Interior.Color = xlNone
a = rng.Value
cTot = Int(rng.Columns.Count / 5) + 1
'
ReDim b(1 To UBound(a, 1) * cTot, 1 To UBound(a, 2) * cTot)
'
'Almacena en un diccionario todos los números de tres en tres
For j = 1 To UBound(a, 2) Step 5
For i = 2 To UBound(a, 1) Step 2
'Revisar celdas mayor a 10
If a(i + 1, j) > 10 Then _
If rngRoj Is Nothing Then Set rngRoj = Cells(i + 1, j + 2) Else Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2))
If a(i + 1, j + 1) > 10 Then _
If rngRoj Is Nothing Then Set rngRoj = Cells(i + 1, j + 2 + 1) Else Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 1))
If a(i + 1, j + 2) > 10 Then _
If rngRoj Is Nothing Then Set rngRoj = Cells(i + 1, j + 2 + 2) Else Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 2))
'
If a(i, j) <> "" Then
cad = a(i, j) & "|" & a(i, j + 1) & "|" & a(i, j + 2)
If Not dic.exists(cad) Then
y = y + 1
dic(cad) = 1 & "|" & y & "|" & 1
Else
x = Split(dic(cad), "|")(0)
n = Split(dic(cad), "|")(1)
m = Split(dic(cad), "|")(2)
x = x + 1
dic(cad) = x & "|" & n & "|" & m
End If
x = Split(dic(cad), "|")(0)
n = Split(dic(cad), "|")(1)
m = Split(dic(cad), "|")(2)
'Alamcena en la matriz 'b' todas las coordenas (fila, columna) de los números
b(n, m) = i & "|" & j
m = m + 1
dic(cad) = x & "|" & n & "|" & m
End If
Next
Next
'
'Revisa cuáles números (de 3) tienen duplicados
For Each ky In dic.keys
x = Split(dic(ky), "|")(0)
If x > 1 Then
'si tiene duplicado, obtiene los datos del diccionario
n = Split(dic(ky), "|")(1)
m = Split(dic(ky), "|")(2) - 1
For k = 1 To m
'obtiene las coordenas de la matriz 'b' de las celdas a colorear
coordenada = b(n, k)
i = Split(coordenada, "|")(0)
j = Split(coordenada, "|")(1) + 2
If rngAma Is Nothing Then _
Set rngAma = Cells(i, j).Resize(1, 3) Else Set rngAma = Union(rngAma, Cells(i, j).Resize(1, 3))
Next
End If
Next
'colorea las celdas
If Not rngAma Is Nothing Then rngAma.Interior.Color = vbYellow
If Not rngRoj Is Nothing Then rngRoj.Interior.Color = vbRed
End Sub
Solo quiero que se ejecute el proceso de celda amarilla y eliminar el proceso de la celda roja (números >10)
Exacto los colores rojos en fila 3,5 7, hasta 201 valores mayores a 10
La macro ya pone los rojos para las filas: 3,5,7... tal y como lo indicaste.
Pero si ya no quieres los rojos, entonces simplemente elimina esta línea de la macro:
If Not rngRoj Is Nothing Then rngRoj.Interior.Color = vbRed
Ejecuto el código y me señala este error
If a(i + 1, j) > 10 Then
¿Qué dice el error?
¿Modificaste algo en la macro?
¿Cuántas filas tienes en el rango?
Listo dante elimine esta línea de código y queda perfecta la condición amarilla
If Not rngRoj Is Nothing Then rngRoj.Interior.Color = vbRed
pero ahora como coloreo las filas 3,5,7 hasta 201 de los colores mayores que 10
Cambia esta línea:
If a(i + 1, j) > 10 Then
Por esta:
For i = 2 To UBound(a, 1) - 1 Step 2
Regresa la línea:
If Not rngRoj Is Nothing Then rngRoj.Interior.Color = vbRed
Esa línea es para colorear el rojo
La macro pone rojos y amarillos.
Sub colorearnumeros_2()
'Por Dante Amor
Dim a As Variant, b As Variant, ky As Variant
Dim i As Long, j As Long, k As Long, lr As Long
Dim n As Long, m As Long, x As Long, y As Long, cTot As Long
Dim cad As String, coordenada As String
Dim dic As Object
Dim rng As Range, rngAma As Range, rngRoj As Range
'
lr = Range("C:AD").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row + 1
Set rng = Range("C1:AD" & lr)
Set dic = CreateObject("Scripting.Dictionary")
rng.Interior.Color = xlNone
a = rng.Value
cTot = Int(rng.Columns.Count / 5) + 1
'
ReDim b(1 To UBound(a, 1) * cTot, 1 To UBound(a, 2) * cTot)
'
'Almacena en un diccionario todos los números de tres en tres
For j = 1 To UBound(a, 2) Step 5
For i = 2 To UBound(a, 1) - 1 Step 2
'Revisar celdas mayor a 10
If a(i + 1, j) > 10 Then _
If rngRoj Is Nothing Then Set rngRoj = Cells(i + 1, j + 2) Else Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2))
If a(i + 1, j + 1) > 10 Then _
If rngRoj Is Nothing Then Set rngRoj = Cells(i + 1, j + 2 + 1) Else Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 1))
If a(i + 1, j + 2) > 10 Then _
If rngRoj Is Nothing Then Set rngRoj = Cells(i + 1, j + 2 + 2) Else Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 2))
'
If a(i, j) <> "" Then
cad = a(i, j) & "|" & a(i, j + 1) & "|" & a(i, j + 2)
If Not dic.exists(cad) Then
y = y + 1
dic(cad) = 1 & "|" & y & "|" & 1
Else
x = Split(dic(cad), "|")(0)
n = Split(dic(cad), "|")(1)
m = Split(dic(cad), "|")(2)
x = x + 1
dic(cad) = x & "|" & n & "|" & m
End If
x = Split(dic(cad), "|")(0)
n = Split(dic(cad), "|")(1)
m = Split(dic(cad), "|")(2)
'Alamcena en la matriz 'b' todas las coordenas (fila, columna) de los números
b(n, m) = i & "|" & j
m = m + 1
dic(cad) = x & "|" & n & "|" & m
End If
Next
Next
'
'Revisa cuáles números (de 3) tienen duplicados
For Each ky In dic.keys
x = Split(dic(ky), "|")(0)
If x > 1 Then
'si tiene duplicado, obtiene los datos del diccionario
n = Split(dic(ky), "|")(1)
m = Split(dic(ky), "|")(2) - 1
For k = 1 To m
'obtiene las coordenas de la matriz 'b' de las celdas a colorear
coordenada = b(n, k)
i = Split(coordenada, "|")(0)
j = Split(coordenada, "|")(1) + 2
If rngAma Is Nothing Then _
Set rngAma = Cells(i, j).Resize(1, 3) Else Set rngAma = Union(rngAma, Cells(i, j).Resize(1, 3))
Next
End If
Next
'colorea las celdas
If Not rngAma Is Nothing Then rngAma.Interior.Color = vbYellow
If Not rngRoj Is Nothing Then rngRoj.Interior.Color = vbRed
End Sub¿O cuál es el problema con los rojos?
Si me ayudas con una imagen y me aclaras cuál es el problema con los rojos.
Es mi ejemplo, pone rojos en las filas nones, y amarillos en las filas pares:
Dante ejecute el primer código y elimine la línea que dijiste y funciona excelente pero lo que me faltaría es que se coloree la fila 3, 5, 7, 9 hasta la fila 201 los valores mayores a 10 solo en esas filas ya que su código lo ejecutaba en las filas 2,4,6,8, hasta 200 ese es el error
Pero si ves mi imagen las filas coloreadas son las 3,5,7, etc
Prueba nuevamente con última macro que puse.
Pero lo que me faltaría es que se coloree la fila 3, 5, 7, 9 hasta la fila 201 los valores mayores a 10
No falta. Esa macro ya está actualizada para poner el rojo.
