'
Option Explicit
'
Sub abc()
Dim a, b, c, ii, i, j, k, d(6)
[b:h].Interior.ColorIndex = xlNone
a = Range("b1:h" & Cells(Rows.Count, "b").End(xlUp).Row + 1).Value
If UBound(a) Mod 7 Then MsgBox "!": Exit Sub
For i = 0 To UBound(d)
Set d(i) = CreateObject("scripting.dictionary")
Next
For ii = 1 To UBound(a) Step 7
For i = ii To ii + 5
For j = 1 To UBound(a, 2)
d(i - ii + 1)(a(i, j)) = 1
d(0)(a(i, j)) = d(0)(a(i, j)) + 1
Next
Next
b = Application.Transpose(Array(d(0).keys, d(0).items))
For i = 1 To UBound(b) - 1
For j = i + 1 To UBound(b)
If b(i, 2) + b(j, 2) = 6 Then
For k = 1 To UBound(d)
If Not (d(k).exists(b(i, 1)) Xor d(k).exists(b(j, 1))) Then Exit For
Next
If k = UBound(d) + 1 Then
d(0).RemoveAll
d(0)(b(i, 1)) = 1: d(0)(b(j, 1)) = 1
Exit For
End If
End If
Next
If j < UBound(b) + 1 Then Exit For
Next
If i < UBound(b) Then
For i = ii To ii + 5
For j = 1 To UBound(a, 2)
If d(0).exists(a(i, j)) Then _
Cells(i, j + 1).Interior.Color = vbGreen: Exit For
Next
Next
End If
For i = 0 To 6: d(i).RemoveAll: Next
Next
End Sub