modificar codigo para resaltar en 3 celdas en linea

[dragonfire33]

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,

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

 

[DanteAmor]

Exacto experto Dante en vertical la distancia es de 6 y en horizontal de 4 celda a celda

Puedes explicarlo con ejemplos, a qué le llamas vertical y a qué le llamas horizontal?
Tal vez, yo pueda realizar la macro y tú le ajustas las celdas en horizontal y el número de celdas en vertical, ya que sigo sin entender muy bien qué necesitas.

 

[dragonfire33]

Algo así como la imagen horizontal es a la derecha de la hoja y vertical es hacia abajo de la columna(las bordeadas no se deben resaltar)

 

[dragonfire33]

Algo así como la imagen (no resaltar las que están bordeadas)

 

[dragonfire33]

Puedes explicarlo con ejemplos, a qué le llamas vertical y a qué le llamas horizontal?
Tal vez, yo pueda realizar la macro y tú le ajustas las celdas en horizontal y el número de celdas en vertical, ya que sigo sin entender muy bien qué necesitas.

La idea es que se resalten solamente aquellas celdas que se repitan 3 veces la misma coincidencia desde la columna e1 en adelante pero si hay algún número que también coincida con los tres números resaltados en esa misma fila pero en diferente coincidencia dos últimas cifras se evite de resaltar

 

[dragonfire33]

Hola Dragon.
En esta ocasión no te podré ayudar, ya que sigo sin entender qué necesitas.

Tus ejemplos no coinciden con tu explicación, por ejemplo:

View attachment 115464

Entonces para entender, quieres comparar las posiciones 1-2, 1-3, 1-4, 2-3, 3-4 y 3-4, de manera vertical y horizontal.
Resaltar el fondo gris y el color del font siempre que existan 3 veces.

Duda: si existen más de 3 veces, también se aplica el formato?


Espero tus comentarios.

hola maestro dante alguna idea para ejecutar el codigo

 

[DanteAmor]

Hola:
En esta ocasión no podré ayudarte. Estuve intentando pero es muy complicada tu solicitud.
Tal vez alguien más, desde otro enfoque, pueda ayudarte.
Saludos
Dante Amor