Realizar pintado a combinaciones numéricas en hoja excel
Para dante:
Como puedo realizar en el código el pintado de las combinaciones numéricas 123, 321, 132, 312, etc.
1 Respuesta
Te paso la macro actualizada para poner todas las combinaciones de 3 números.
Sub colorearnumeros_4()
'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 m As Long, n As Long, x As Long, y As Long, cTot As Long
Dim cad As String, coordenada As String
Dim dic1 As Object, dic2 As Object
Dim rng As Range, rngAma As Range, rngRoj As Range
'
lr = Range("C:AD").Find("*", , xlValues, xlPart, xlByRows, xlPrevious).Row
Set rng = Range("C1:AD" & lr)
Set dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set rngAma = Cells(1, 3)
Set rngRoj = Cells(1, 3)
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 + 0) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 0))
If a(i + 1, j + 1) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 1))
If a(i + 1, j + 2) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 2))
'
If a(i, j) <> "" Then
For w = 1 To 6
'combinaciones de 3 números
Select Case w
Case 1: cad = a(i, j + 0) & "|" & a(i, j + 1) & "|" & a(i, j + 2)
Case 2: cad = a(i, j + 0) & "|" & a(i, j + 2) & "|" & a(i, j + 1)
Case 3: cad = a(i, j + 1) & "|" & a(i, j + 0) & "|" & a(i, j + 2)
Case 4: cad = a(i, j + 1) & "|" & a(i, j + 2) & "|" & a(i, j + 0)
Case 5: cad = a(i, j + 2) & "|" & a(i, j + 0) & "|" & a(i, j + 1)
Case 6: cad = a(i, j + 2) & "|" & a(i, j + 1) & "|" & a(i, j + 0)
End Select
'
coordenada = i & "|" & j
If Not dic1.exists(cad) Then
y = y + 1
dic1(cad) = 1 & "|" & y & "|" & 1
dic2(coordenada) = Empty
Else
If Not dic2.exists(coordenada) Then
x = Split(dic1(cad), "|")(0)
n = Split(dic1(cad), "|")(1)
m = Split(dic1(cad), "|")(2)
x = x + 1
dic1(cad) = x & "|" & n & "|" & m
End If
End If
x = Split(dic1(cad), "|")(0)
n = Split(dic1(cad), "|")(1)
m = Split(dic1(cad), "|")(2)
'Alamcena en la matriz 'b' todas las coordenas (fila, columna) de los números
b(n, m) = coordenada
m = m + 1
dic1(cad) = x & "|" & n & "|" & m
Next
End If
Next
Next
'
'Revisa cuáles números (de 3) tienen duplicados
For Each ky In dic1.keys
x = Split(dic1(ky), "|")(0)
If x > 1 Then
'si tiene duplicado, obtiene los datos del diccionario
n = Split(dic1(ky), "|")(1)
m = Split(dic1(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
Set rngAma = Union(rngAma, Cells(i, j).Resize(1, 3))
Next
End If
Next
'colorea las celdas
rngAma.Interior.Color = vbYellow
rngRoj.Interior.Color = vbRed
Cells(1, 3).Interior.Color = xlNone
End Sub
dante me señala este error
b(n, m) = coordenada
dante por que me señala este error si estamos trabajando con el mismo rango
a que se refiere la cordenada dante
¿Qué dice el error?
¿Sigues con 201 filas?
Envíame tu archivo para revisar los datos.
b(n, m) = coordenada
Ayudaría mucho si, cuando te aparece un mensaje de error, comentas:
- En cuál línea se detiene la macro,
- Qué dice el mensaje de error
- Si acercas el mouse a las variables y puedes ver qué valor tiene cada variable y escribes aquí, por ejemplo, qué valor tiene la variable n, qué valor tiene la variable m, qué valor tiene la variable coordenada.
- La variable coordenada está compuesta por la variable i y la variable j, qué valor tiene i y qué valor tiene j
- Qué dato tienes en la celda de fila i y columna j
Solamente es un ejemplo de lo que necesito para rastrear el problema y encontrar una solución.
Hice un par de ajustes a la macro colorearnumeros_5, para considerar si el último registro termina en una fila par o una fila non.
Sub colorearnumeros_5()
'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, w As Long
Dim m As Long, n As Long, x As Long, y As Long, cTot As Long
Dim cad As String, coordenada As String
Dim dic1 As Object, dic2 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 dic1 = CreateObject("Scripting.Dictionary")
Set dic2 = CreateObject("Scripting.Dictionary")
Set rngAma = Cells(1, 3)
Set rngRoj = Cells(1, 3)
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 + 0) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 0))
If a(i + 1, j + 1) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 1))
If a(i + 1, j + 2) > 10 Then Set rngRoj = Union(rngRoj, Cells(i + 1, j + 2 + 2))
'
If a(i, j) <> "" Then
For w = 1 To 6
'combinaciones de 3 números
Select Case w
Case 1: cad = a(i, j + 0) & "|" & a(i, j + 1) & "|" & a(i, j + 2)
Case 2: cad = a(i, j + 0) & "|" & a(i, j + 2) & "|" & a(i, j + 1)
Case 3: cad = a(i, j + 1) & "|" & a(i, j + 0) & "|" & a(i, j + 2)
Case 4: cad = a(i, j + 1) & "|" & a(i, j + 2) & "|" & a(i, j + 0)
Case 5: cad = a(i, j + 2) & "|" & a(i, j + 0) & "|" & a(i, j + 1)
Case 6: cad = a(i, j + 2) & "|" & a(i, j + 1) & "|" & a(i, j + 0)
End Select
'
coordenada = i & "|" & j
If Not dic1.exists(cad) Then
y = y + 1
dic1(cad) = 1 & "|" & y & "|" & 1
dic2(coordenada) = Empty
Else
If Not dic2.exists(coordenada) Then
x = Split(dic1(cad), "|")(0)
n = Split(dic1(cad), "|")(1)
m = Split(dic1(cad), "|")(2)
x = x + 1
dic1(cad) = x & "|" & n & "|" & m
End If
End If
x = Split(dic1(cad), "|")(0)
n = Split(dic1(cad), "|")(1)
m = Split(dic1(cad), "|")(2)
'Alamcena en la matriz 'b' todas las coordenas (fila, columna) de los números
b(n, m) = coordenada
m = m + 1
dic1(cad) = x & "|" & n & "|" & m
Next
End If
Next
Next
'
'Revisa cuáles números (de 3) tienen duplicados
For Each ky In dic1.keys
x = Split(dic1(ky), "|")(0)
If x > 1 Then
'si tiene duplicado, obtiene los datos del diccionario
n = Split(dic1(ky), "|")(1)
m = Split(dic1(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
Set rngAma = Union(rngAma, Cells(i, j).Resize(1, 3))
Next
End If
Next
'colorea las celdas
rngAma.Interior.Color = vbYellow
rngRoj.Interior.Color = vbRed
Cells(1, 3).Interior.Color = xlNone
End SubPrueba y me comentas. Y si aparece un error, ya sabes que debes poner la mayor cantidad de información posible.
Me sigue marcado el mismo error dante, ya te envíe el libro a su correo
b(n, m) = coordenada
< subindice fuera de intervalo
x = 164
n = 1
m = 169
Un pequeño detalle, debe ser 1 en lugar de 2.
Cambia esta línea:
ReDim b(1 To UBound(a, 1) * cTot, 1 To UBound(a, 2) * cTot)
Por esta línea:
ReDim b(1 To UBound(a, 1) * cTot, 1 To UBound(a, 1) * cTot)
me marca el mismo error
Dante te envíe el libro al correo
Lo probé con tu archivo y me funciona
Te envío tu archivo funcionando
