Option Explicit
Sub Taz()
Dim i%, j%, c1%, c2%, TC%(), TL%(), k%, n%
n = Application.InputBox(prompt:="Taille de la grille ?", Default:=8)
'0->3
For i = 1 To n
For j = 1 To n
If Cells(i, j) <> "" Then
Cells(i, j).Font.Color = RGB(255, 0, 0)
If Cells(i, j) = 0 Then Cells(i, j) = 3
End If
Next j
Next i
Do
'tests simples
c1 = 0
c2 = 0
Do
For i = 1 To n
For j = 1 To n
If Cells(i, j) = "" Then
'test gauche
If j > 2 Then
If Cells(i, j - 2) = 3 And Cells(i, j - 1) = 3 Then
Cells(i, j) = 1
c1 = c1 + 1
Exit For
End If
If Cells(i, j - 2) = 1 And Cells(i, j - 1) = 1 Then
Cells(i, j) = 3
c1 = c1 + 1
c1 = c1 + 1
Exit For
End If
End If
'test droit
If j < n - 1 Then
If Cells(i, j + 2) = 3 And Cells(i, j + 1) = 3 Then
Cells(i, j) = 1
c1 = c1 + 1
Exit For
End If
If Cells(i, j + 2) = 1 And Cells(i, j + 1) = 1 Then
Cells(i, j) = 3
c1 = c1 + 1
Exit For
End If
End If
'test haut
If i > 2 Then
If Cells(i - 2, j) = 3 And Cells(i - 1, j) = 3 Then
Cells(i, j) = 1
c1 = c1 + 1
Exit For
End If
If Cells(i - 2, j) = 1 And Cells(i - 1, j) = 1 Then
Cells(i, j) = 3
c1 = c1 + 1
Exit For
End If
End If
'test bas
If i < n - 1 Then
If Cells(i + 2, j) = 3 And Cells(i + 1, j) = 3 Then
Cells(i, j) = 1
c1 = c1 + 1
Exit For
End If
If Cells(i + 2, j) = 1 And Cells(i + 1, j) = 1 Then
Cells(i, j) = 3
c1 = c1 + 1
Exit For
End If
End If
'test horizontal
If j > 1 And j < n Then
If Cells(i, j - 1) = Cells(i, j + 1) And Cells(i, j - 1) <> "" Then
Cells(i, j) = 4 - Cells(i, j - 1)
c1 = c1 + 1
Exit For
End If
End If
'test vertical
If i > 1 And i < n Then
If Cells(i - 1, j) = Cells(i + 1, j) And Cells(i - 1, j) <> "" Then
Cells(i, j) = 4 - Cells(i - 1, j)
c1 = c1 + 1
Exit For
End If
End If
End If
Next j
'test ligne
If WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 3) = n / 2 Then
For j = 1 To n
If Cells(i, j) = "" Then
Cells(i, j) = 1
c1 = c1 + 1
End If
Next j
End If
If WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 1) = n / 2 Then
For j = 1 To n
If Cells(i, j) = "" Then
Cells(i, j) = 3
c1 = c1 + 1
End If
Next j
End If
Next i
'test colonnes
For j = 1 To n
If WorksheetFunction.CountIf(Range(Cells(1, j), Cells(n, j)), 3) = n / 2 Then
For i = 1 To n
If Cells(i, j) = "" Then
Cells(i, j) = 1
c1 = c1 + 1
End If
Next i
End If
If WorksheetFunction.CountIf(Range(Cells(1, j), Cells(n, j)), 1) = n / 2 Then
For i = 1 To n
If Cells(i, j) = "" Then
Cells(i, j) = 3
c1 = c1 + 1
End If
Next i
End If
Next j
If c1 = c2 Then Exit Do
c2 = c1
Loop
If WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 1) = (n ^ 2) / 2 And WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 3) = (n ^ 2) / 2 Then GoTo Line1
'tests croisés
ReDim TL(1 To n, 1 To 2)
ReDim TC(1 To n, 1 To 2)
c1 = 0
c2 = 0
For i = 1 To n
TL(i, 1) = WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 1)
TL(i, 2) = WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(i, n)), 3)
TC(i, 1) = WorksheetFunction.CountIf(Range(Cells(1, i), Cells(n, i)), 1)
TC(i, 2) = WorksheetFunction.CountIf(Range(Cells(1, i), Cells(n, i)), 3)
Next i
Do
For i = 1 To n
For j = 1 To n
If Cells(i, j) = "" Then
For k = 1 To 2
If TL(i, k) * TC(j, k) = 16 Then
Cells(i, j) = IIf(k = 1, 1, 3)
c1 = c1 + 1
TL(i, k) = TL(i, k) + 1
TC(j, k) = TC(j, k) + 1
End If
Next k
End If
Next j
Next i
If c1 = c2 Then Exit Do
c2 = c1
Loop
If WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 1) = (n ^ 2) / 2 And WorksheetFunction.CountIf(Range(Cells(1, 1), Cells(n, n)), 3) = (n ^ 2) / 2 Then GoTo Line1
Loop
Line1:
'retour aux 0
For i = 1 To n
For j = 1 To n
If Cells(i, j) = 3 Then
Cells(i, j) = 0
End If
Next j
Next i
End Sub