dragonfire33
Board Regular
- Joined
- Oct 7, 2021
- Messages
- 90
- Office Version
- 365
- Platform
- Windows
hola buenas como puedo agregarle a este codigo para que se resalte la coincidencia en 3 celdas en linea tanto vertical como horizontal en todas las celdas del rango,
VBA Code:
Sub recorre2()'el arreglo seria en este codigo
Application.ScreenUpdating = False
Dim Rango As Range
Set Rango = Range("E1:" & UltimaColumna & UltimaFila)
For Each rg In Rango ' recorre el rango
If rg <> "" Then
For i = 1 To 4 ' comprueba derecha
If rg.Offset(0, i) <> "" Then ' si la celda no esta vacia
tinta = Comprueba(rg.Value, rg.Offset(0, i))
If tinta <> 0 Then
coloreacelda rg.Address, tinta ' colorea la celda inicial
coloreacelda rg.Offset(0, i).Address, tinta ' colorea la celda final
End If
End If
Next
For i = 1 To 4 ' comprueba abajo
If rg.Offset(i, 0) <> "" Then ' si la celda no esta vacia
tinta = Comprueba(rg.Value, rg.Offset(i, 0))
If tinta <> 0 Then
coloreacelda rg.Address, tinta ' colorea la celda inicial
coloreacelda rg.Offset(i, 0).Address, tinta ' colorea la celda final
End If
End If
Next
End If
Next
Application.ScreenUpdating = True
End Sub
Function Comprueba(Num1 As String, Num2 As String) As Integer
Dim n1(3) As Variant
Dim n2(3) As Variant
For i = 0 To 3 ' llena los arrays numero a numero
n1(i) = Mid(Num1, i + 1, 1)
n2(i) = Mid(Num2, i + 1, 1)
Next
If n1(0) = n2(0) And n1(1) = n2(1) Then Comprueba = 1: Exit Function 'dos primeras
If n1(1) = n2(1) And n1(2) = n2(2) Then Comprueba = 2: Exit Function 'dos del centro
If n1(2) = n2(2) And n1(3) = n2(3) Then Comprueba = 3: Exit Function 'dos ultimas
If n1(1) = n2(1) And n1(3) = n2(3) Then Comprueba = 4: Exit Function 'segunda y cuarta
If n1(0) = n2(0) And n1(3) = n2(3) Then Comprueba = 5: Exit Function 'primera y cuarta
If n1(0) = n2(0) And n1(2) = n2(2) Then Comprueba = 6: Exit Function 'primera y tercera
Comprueba = 0
End Function
Sub coloreacelda(cl As String, color As Variant)
Dim celda As Range
Set celda = Range(cl)
'esta linea hace que mantenga el color asignado
'anteriormente en caso de duplicidad de coincidencia
If celda.Font.color <> vbBlack Then Exit Sub
Select Case color
Case 1
pinta = RGB(126, 126, 23) 'amarillo
Case 2
pinta = RGB(2, 80, 28) 'verde
Case 3
pinta = RGB(160, 11, 97) 'morado
Case 4, 5, 6
pinta = vbRed 'rojo
End Select
celda.Font.color = pinta ' color del texto
celda.Interior.color = RGB(208, 205, 258) ' color interior de la celda
End Sub
Function UltimaColumna() ' busca la ultima columna, fila ocupada
Dim rg As Range
Set rg = Cells.Find(What:="*", _
After:=Cells(1, 1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rg Is Nothing Then
UltimaColumna = Split(rg.Address, "$")(1)
Else
UltimaColumna = "z1"
End If
End Function
Function UltimaFila()
Dim rg As Range
Set rg = Cells.Find(What:="*", _
After:=Cells(1, 1), _
LookAt:=xlPart, _
LookIn:=xlFormulas, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rg Is Nothing Then
UltimaFila = rg.Row
Else
UltimaFila = 1
End If
End Function
