Agregar condición de resalte de celda al código

Tengo el siguiente código y lo que hace es resaltar cualquier coincidencia de dos cifras en sus diferentes posiciones en la celda de acuerdo a una distancia de 4 celdas hacia abajo de la columna como a la fila de su derecha, y lo hace perfecto pero me gustaría agregarle una condición al código así:

Me gustaría que se resalten solamente aquellas celdas que repiten la misma coincidencia tres veces en esa misma distancia de celdas hacia abajo o hacia la derecha de esa misma fila y si hubiera un número que coincida con cualquiera de los números resaltados en la fila o columna y no se repita tres veces que no se resalte; por ejemplo en la misma fila 1 columna e1 está el 9820 y en la columna h1 el 9845 y el la columna k1 el 9863 se resaltarian las tres celdas ya que sus dos primeras cifras se repiten, pero digamos que en esa misma fila está en la columna g1 el 7863 y como está el 9863 en la columna k1 se resalta por sus dos últimas cifras y eso es lo que quisiera evitar que si hay algún número que coincida tanto en columna como en fila y no se repita 3 veces que se evite resaltar

Gracias

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