Excel numeri uguali

Sub Colore()
Dim area1 As Range, area2 As Range
Dim i As Long, j As Long, h As Long, k As Long
Dim x1 As String, x2 As String, x3 As String
Dim y1 As String, y2 As String, y3 As String
Dim cn As Integer
Set area1 = Range("B3:D7")
Set area2 = Range("E3:G7")
area1.Interior.ColorIndex = 6
area2.Interior.ColorIndex = 15
For i = 3 To 7
  For j = 2 To 3
    x1 = Cells(i, j) & Cells(i, j + 1)
    x2 = Cells(i, j) & Cells(i, j + 2)
    x3 = Cells(i, j + 1) & Cells(i, j + 2)
    For h = 3 To 7
      For k = 5 To 6
        y1 = Cells(h, k) & Cells(h, k + 1)
        y2 = Cells(h, k) & Cells(h, k + 2)
        y3 = Cells(h, k + 1) & Cells(h, k + 2)
        If x1 = y1 Then
          'quadro1 1a e 2a uguale a quadro2 1a e 2a
          Cells(i, j).Interior.ColorIndex = 3
          Cells(i, j + 1).Interior.ColorIndex = 3
          Cells(h, k).Interior.ColorIndex = 3
          Cells(h, k + 1).Interior.ColorIndex = 3
        ElseIf x1 = y2 Then
          'quadro1 1a e 2a uguale a quadro2 1a e 3a
          Cells(i, j).Interior.ColorIndex = 3
          Cells(i, j + 1).Interior.ColorIndex = 3
          Cells(h, k).Interior.ColorIndex = 3
          Cells(h, k + 2).Interior.ColorIndex = 3
        ElseIf x1 = y3 Then
          'quadro1 1a e 2a uguale a quadro2 2a e 3a
          Cells(i, j).Interior.ColorIndex = 3
          Cells(i, j + 1).Interior.ColorIndex = 3
          Cells(h, k + 1).Interior.ColorIndex = 3
          Cells(h, k + 2).Interior.ColorIndex = 3
        ElseIf x2 = y1 Then
          'quadro1 1a e 3a uguale a quadro 2 1a e 2a
          Cells(i, j).Interior.ColorIndex = 3
          Cells(i, j + 2).Interior.ColorIndex = 3
          Cells(h, k).Interior.ColorIndex = 3
          Cells(h, k + 1).Interior.ColorIndex = 3
        ElseIf x2 = y2 Then
          'quadro1 1a e 3a uguale quadro2 1a e 3a
          Cells(i, j).Interior.ColorIndex = 3
          Cells(i, j + 2).Interior.ColorIndex = 3
          Cells(h, k).Interior.ColorIndex = 3
          Cells(h, k + 2).Interior.ColorIndex = 3
        'quadro1 2a e 3a 0guale a quadro2 1a e 2a
        ElseIf x3 = y1 Then
          'quadro1 2a e 3a uguale a quadro2 1a e 2a
          Cells(i, j + 1).Interior.ColorIndex = 3
          Cells(i, j + 2).Interior.ColorIndex = 3
          Cells(h, k).Interior.ColorIndex = 3
          Cells(h, k + 1).Interior.ColorIndex = 3
        ElseIf x3 = y3 Then
          'quadro1 2a e 3a uguale a quadro2 2a e 3a
          Cells(i, j + 1).Interior.ColorIndex = 3
          Cells(i, j + 2).Interior.ColorIndex = 3
          Cells(h, k + 1).Interior.ColorIndex = 3
          Cells(h, k + 2).Interior.ColorIndex = 3
        End If
      Next k
    Next h
  Next j
Next i
End Sub

Option Explicit

Sub Ambo()
Dim i As Long, j As Long
Dim rig1 As Range, rig2 As Range, c As Range, x As Range, area1 As Range, area2 As Range
Dim n As Integer, h As Integer, a As Integer, clr As Integer
Dim pos(1 To 4) As String
Set area1 = Range("B3:D7")
Set area2 = Range("E3:G7")
area1.Interior.ColorIndex = 19
area2.Interior.ColorIndex = 15
clr = 2
For i = 3 To 7
  Set rig1 = Range("B" & i & ":D" & i)
  For j = 3 To 7
    Set rig2 = Range("E" & j & ":G" & j)
    n = 0: a = 0
    For Each c In rig1
      For Each x In rig2
        If c.Value = x.Value Then
          n = n + 1
          a = a + 1
          pos(a) = c.Address
          a = a + 1
          pos(a) = x.Address
          If n = 2 Then
            clr = clr + 1
            For h = 1 To 4
              Range(pos(h)).Interior.ColorIndex = clr
            Next h
          End If
        End If
      Next
    Next
  Next j
Next i
End Sub