Projet Sudoku débutant

**johnny_78** · 24/02/2011, 11h58

Bonjour!
Je fais appel a vos connaissance car les miennes sont épuisées et malgré mes heures de recherche je ne trouve pas de solutions à mes soucis.
Voici mon problème:
J'ai créé une fonction qui détermine si des valeurs sont repétées mais malheureusement qu'importe les Ranges données à cette fonction, elle les ignore et se contente de calculer de A1 à C3.

Ce code est censé vérifier l'état d'un tableau de Sudoku 9x9
le code pour les colonnes et Rows fonctionne, mais pas les 3x3

Merci de votre temps.
John

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
Sub test3x3()
 
result3x3 = is3x3Unique("A1:C3")
MsgBox (result3x3)
End Sub
 
Function is3x3Unique(Inrange) As Boolean
Dim c1 As Boolean
Dim c2 As Boolean
Dim c3 As Boolean
Dim c4 As Boolean
Dim c5 As Boolean
Dim c6 As Boolean
Dim c7 As Boolean
Dim c8 As Boolean
 
 
 
If Cells(1, 1) <> Cells(1, 2) And Cells(1, 1) <> Cells(1, 3) And Cells(1, 1) <> Cells(2, 1) And Cells(1, 1) <> Cells(2, 2) And Cells(1, 1) <> Cells(2, 3) And Cells(1, 1) <> Cells(3, 1) And Cells(1, 1) <> Cells(3, 2) And Cells(1, 1) <> Cells(3, 3) _
Then c1 = True Else c1 = False
 
If Cells(1, 2) <> Cells(1, 3) And Cells(1, 2) <> Cells(2, 1) And Cells(1, 2) <> Cells(2, 2) And Cells(1, 2) <> Cells(2, 3) And Cells(1, 2) <> Cells(3, 1) And Cells(1, 2) <> Cells(3, 2) And Cells(1, 2) <> Cells(3, 3) _
Then c2 = True Else c2 = False
 
If Cells(1, 3) <> Cells(2, 1) And Cells(1, 3) <> Cells(2, 2) And Cells(1, 3) <> Cells(2, 3) And Cells(1, 3) <> Cells(3, 1) And Cells(1, 3) <> Cells(3, 2) And Cells(1, 3) <> Cells(3, 3) _
Then c3 = True Else c3 = False
 
If Cells(2, 1) <> Cells(2, 2) And Cells(2, 1) <> Cells(2, 3) And Cells(2, 1) <> Cells(3, 1) And Cells(2, 1) <> Cells(3, 2) And Cells(2, 1) <> Cells(3, 3) _
Then c4 = True Else c4 = False
 
If Cells(2, 2) <> Cells(2, 3) And Cells(2, 2) <> Cells(3, 1) And Cells(2, 2) <> Cells(3, 2) And Cells(2, 2) <> Cells(3, 3) _
Then c5 = True Else c5 = False
 
If Cells(2, 3) <> Cells(3, 1) And Cells(3, 1) <> Cells(3, 2) And Cells(2, 3) <> Cells(3, 3) _
Then c6 = True Else c6 = False
 
If Cells(3, 1) <> Cells(3, 2) And Cells(3, 1) <> Cells(3, 3) _
Then c7 = True Else: c7 = False
 
If Cells(3, 2) <> Cells(3, 3) _
Then c8 = True Else c8 = False
 
If c1 And c2 And c3 And c4 And c5 And c6 And c7 And c8 = True _
Then is3x3Unique = True
 
If c1 And c2 And c3 And c4 And c5 And c6 And c7 And c8 = True _
Then Exit Function Else _
MsgBox ("the highlighted 3x3 has a repeated value")
Range(Cells(1, 1), Cells(3, 3)).Select
    Cells(3, 3).Activate
    With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
    End With
 
 
End Function

**mercatog** · 24/02/2011, 12h19

Pour créer une fonction booléenne qui cherche l'existence d'une valeur X dans une plage P, il suffit de compter le nombre de X dans P
Exemple

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
Function Is3x3Unique(ByVal Valeur As Integer, InRange As Range) As Boolean
'Valeur: Valeur à chercher l'existence
'InRnge: Plage de recherche de doublons
Is3x3Unique = Application.CountIf(InRange, Valeur) = 1
End Function

**johnny_78** · 24/02/2011, 12h51

Merci Beaucoup Mercatog,
En faite je n'avais besoin que d'une ligne au lieu de me repeter n fois.
J'ai editer mon code et la fonction repère bien les doublons mais il m'envoie un message lorsqu'un chiffre manque aussi.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
Sub try()
For i = 1 To 9 
result = Is3x3Unique(i, Range("D14:L14"))
If result <> True Then _
MsgBox ("le chiffre" & i & " est repeter dans cette ligne")
Next i
End Sub
 
Function Is3x3Unique(ByVal Valeur As Integer, InRange As Range) As Boolean
'Valeur: Valeur à chercher l'existence
'InRnge: Plage de recherche de doublons
 
Is3x3Unique = Application.CountIf(InRange, Valeur) = 1
 
End Function

**mercatog** · 24/02/2011, 12h57

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
Function Is3x3Unique(ByVal Valeur As Integer, InRange As Range) As Boolean
'Valeur: Valeur à chercher l'existence
'InRnge: Plage de recherche de doublons
 
Is3x3Unique = Application.CountIf(InRange, Valeur) <= 1
End Function

**johnny_78** · 24/02/2011, 13h15

Vous etes Geniale merci
Si je voulais passer du input D6:F8 au input G6:I8
puis " "D9:F11 ...
est ce que je peut utiliser la reference avec Cells pour utiliser une Variable qui ferais des increments de trois?
merci encore.

ca ne fonctionne pas mais c'est ce que j'essaye d'accomplir.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
 
Sub try()
For x = 4 To 10   'par etapes de trois  
    For y = 6 To 12   ' +3,+3,+3
 
        For i = 1 To 9
        result = IsUnique(i, Cells(x,y):(x+3,y+3))
        If result <> True Then _
        Range(Cells(x, y), Cells(x + 3, y + 3)).Select
        Cells(x, y).Activate
        With Selection.Font
        .Color = -16776961
        .TintAndShade = 0
        End With
        And    'la syntaxe pour rajouter mon Msgbox au If then ?
        MsgBox ("le chiffre" & i & " est repeter dans le 3x3 coloré")
        Next i
    Next y
Next x
 
End Sub
 
Function IsUnique(ByVal Valeur As Integer, InRange As Range) As Boolean
'Valeur: Valeur à chercher l'existence
'InRnge: Plage de recherche de doublons
 
IsUnique = Application.CountIf(InRange, Valeur) <= 1
 
End Function

**mercatog** · 24/02/2011, 13h55

Essaies comme ceci
La fonction a été améliorée pour tenir compte de 3 recherches de doublons:

Recherche sur la ligne entière
Recherche sur la colonne entière
Recherche sur la quadrant (3x3)

La procédure TestTout permet de tester chaque cellule de la plage du sudoku

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
'---------------------------------------------------------------------------------------
' Function  : Is3x3Unique
' Purpose   : Target: Cellule dont la valeur à chercher
'             InRange: Plage global de to Sudokku 9x9
' Fonction qui permet de vérifier si la valeur de Target éxiste en double dans la ligne ou colonne ou quadrant
'---------------------------------------------------------------------------------------
Function IsUnique(Target As Range, InRange As Range) As Boolean
Dim Lig As Range, Col As Range, Part As Range
Dim R As Byte, c As Byte
 
Set Lig = Intersect(Target.EntireRow, InRange)
IsUnique = Application.CountIf(Lig, Target.Value) <= 1                'Cherche doublons sur la ligne entière
Set Lig = Nothing
If IsUnique Then
    Set Col = Intersect(Target.EntireColumn, InRange)
    IsUnique = Application.CountIf(Col, Target.Value) <= 1            'Cherche doublons sur la colonne entière
    Set Col = Nothing
    If IsUnique Then
        R = 3 * ((Target.Row - InRange.Row) \ 3) + InRange.Row
        c = 3 * ((Target.Column - InRange.Column) \ 3) + InRange.Column
        Set Part = Range(Cells(R, c), Cells(R + 2, c + 2))
        IsUnique = Application.CountIf(Part, Target.Value) <= 1       'Cherche doublons sur le "quadrant"
        Set Part = Nothing
    End If
End If
End Function
 
Sub TestTout()
Dim Plage As Range, c As Range
 
Set Plage = Sheets("Feuil1").Range("L10:T18")                        'à adapter: Plage globale du sudoku
For Each c In Plage
    If c.Value <> "" Then
        If Not IsUnique(c, Plage) Then c.Interior.Color = 255
    End If
Next c
Set Plage = Nothing
End Sub

Adapte la Plage de ton sudoku dans la sub TestTout

**johnny_78** · 24/02/2011, 14h38

c'est manifique merci pour vos efforts.
Le seul bug c'est... moi!

Je suis étudiant en premiere année de info niveau "BAC" en Angleterre
J'ai eu au total 4 cours de VBA et ce projet est a rendre. le seul hic c'est que je dois etre capable d'expliquer le fonctionnement du program mais la je suis un peu perdu.

J'ai mis des points d'interrogations audessus du code que je ne comprends pas

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
'---------------------------------------------------------------------------------------
Function IsUnique(ByVal Valeur As Integer, InRange As Range) As Boolean
'Valeur: Valeur à chercher l'existence
'InRnge: Plage de recherche de doublons
 
IsUnique = Application.CountIf(InRange, Valeur) <= 1
 
End Function
 
 
'---------------------------------------------------------------------------------------
' Function  : Is3x3Unique
' Purpose   : Target: Cellule dont la valeur à chercher
'             InRange: Plage global de to Sudokku 9x9
' Fonction qui permet de vérifier si la valeur de Target éxiste en double dans la ligne ou colonne ou quadrant
'---------------------------------------------------------------------------------------
'----------------le numero tester----et la plage entiere
Function IsUnique(Target As Range, InRange As Range) As Boolean
Dim Lig As Range, Col As Range, Part As Range
Dim R As Byte, c As Byte
 
'?-------------?
Set Lig = Intersect(Target.EntireRow, InRange)
IsUnique = Application.CountIf(Lig, Target.Value) <= 1                'Cherche doublons sur la ligne entière
'------------?
Set Lig = Nothing
If IsUnique Then
    Set Col = Intersect(Target.EntireColumn, InRange)
    IsUnique = Application.CountIf(Col, Target.Value) <= 1            'Cherche doublons sur la colonne entière
    Set Col = Nothing
'-------isUnique=true?    
        If IsUnique Then
'---------je pense que cette partie determine l'adress des quadrants mais comment?
        R = 3 * ((Target.Row - InRange.Row) \ 3) + InRange.Row
        c = 3 * ((Target.Column - InRange.Column) \ 3) + InRange.Column
        Set Part = Range(Cells(R, c), Cells(R + 2, c + 2))
        IsUnique = Application.CountIf(Part, Target.Value) <= 1       'Cherche doublons sur le "quadrant"
        Set Part = Nothing
    End If
End If
End Function
 
Sub TestTout()
Dim Plage As Range, c As Range
 
Set Plage = Sheets("Sheet1").Range("D6:L14")                        'à adapter: Plage globale du sudoku
For Each c In Plage
'------------------?
    If c.Value <> "" Then
        If Not IsUnique(c, Plage) Then c.Interior.Color = 255
    End If
Next c
Set Plage = Nothing
End Sub

**mercatog** · 24/02/2011, 15h27

Je n'ai donc pas rendu service en faisant le tout. Mais le mal est déjà fait, ci joint le code commenté

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
Function IsUnique(Target As Range, InRange As Range) As Boolean
Dim Lig As Range, Col As Range, Part As Range
Dim R As Byte, c As Byte
 
'---------------------------------------------------------------------------------------------------------------------------------------
'Target (Variable de type Range): Cellule à traiter (recherche sur sa ligne, sur sa colonne et sur son quadrant si elle est en double)
'InRange (Variable de type Range): Plage 9x9 de ton sudoku
'---------------------------------------------------------------------------------------------------------------------------------------
'Lig (Variable de type Range): Intersection entre la ligne entière de la cellule et la plage InRange (Ce qui nous donne la ligne de 9 cellules sur la plage)
Set Lig = Intersect(Target.EntireRow, InRange)
'IsUnique=True si et seulement si le nombre de valeurs est <=1 (Unicité de la valeur sur la ligne de 9 cellules)
IsUnique = Application.CountIf(Lig, Target.Value) <= 1
'On Libère la variable ligne Lig
Set Lig = Nothing
'Si sur la ligne la valeur est unique (càd IsUnique=True), on va chercher en colonne, Sinon, déjà le problème est posé et on arrête (IsUnique=Fals)
If IsUnique Then
    'Col (Variable de type Range): Intersection entre la colonne entière de la cellule et la plage InRange (Ce qui nous donne la colonne de 9 cellules sur la plage)
    Set Col = Intersect(Target.EntireColumn, InRange)
    'IsUnique=True si et seulement si le nombre de valeurs est <=1 (Unicité de la valeur sur la colonne de 9 cellules)
    IsUnique = Application.CountIf(Col, Target.Value) <= 1
    'On Libère la variable colonne Col
    Set Col = Nothing
    'Si sur la colonne la valeur est ENCORE unique (càd IsUnique=True), on va chercher en quadrant, Sinon, déjà le problème est posé et on arrête (IsUnique=Fals)
    If IsUnique Then
        'R c'est la ligne de la première cellule en haut à gauche du cadrant
        R = 3 * ((Target.Row - InRange.Row) \ 3) + InRange.Row
        'C c'est la colonne de la première cellule en haut à gauche du cadrant
        c = 3 * ((Target.Column - InRange.Column) \ 3) + InRange.Column
        'Part est le quadrant commençant en cells(R,C) et se terminant en cells(R+2,C+2)
        Set Part = Range(Cells(R, c), Cells(R + 2, c + 2))
        'IsUnique=True si et seulement si le nombre de valeurs est <=1 (Unicité de la valeur sur le quadrant de 9 cellules)
        IsUnique = Application.CountIf(Part, Target.Value) <= 1
        'On Libère la variable quadrant Part
        Set Part = Nothing
    End If
End If
End Function
 
Sub TestTout()
Dim Plage As Range, v As Range
 
Set Plage = Sheets("Feuil1").Range("L10:T18")                        'à adapter: Plage globale du sudoku
'On ôte la couleur de fond de notre sudoku
Plage.Interior.ColorIndex = xlNone
'Pour chaque cellule de la plage 9x9 du sudoku
For Each v In Plage
    'Si la cellule est non vide
    If v.Value <> "" Then
        'S'il y a au moins un doublons sur la ligne ou colonne ou quadrant de la cellule non vide v (isunique=false), alors on la colorie zn rouge
        If Not IsUnique(v, Plage) Then v.Interior.Color = 255
    End If
Next v
Set Plage = Nothing
End Sub

PS: Pour une variable booléenne, tu peux écrire l'une ou l'autre

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
If x = true then
'ou simplement
If x then

**johnny_78** · 24/02/2011, 16h14

Vous etes Super!

Je m'excuse de ne pas avoir dévoiler mon identité d'étudiant auparavant et je vous rassure que je compte comprendre et pouvoir reproduire seul, de tel projets.

malgré votre commentaire détaillé Il me reste des questions:

Lorsqu'on "libère une variable" ca a pour effet d'accelerer le program ou d'éviter des erreurs?

Pourquoi doit on diviser puis multiplier par trois ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 R = 3 * ((Target.Row - InRange.Row) \ 3) + InRange.Row

Que veut dire Unicité?

et dernierement si je voulais féliciter le joueur d'avoir completer correctement le jeu est ce que ce code est bon?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
Sub TestTout()
Dim Plage As Range, v As Range
 Dim Count As Integer
 Dim zeroCount As Integer
 Count = 0
 zeroCount = 0
 
Set Plage = Sheets("Feuil1").Range("L10:T18")
'On ôte la couleur de fond de notre sudoku
Plage.Interior.ColorIndex = xlNone
'Pour chaque cellule de la plage 9x9 du sudoku
For Each v In Plage
    'Si la cellule est non vide
    If v.Value <> "" Then GoTo 1 Else zeroCount = zeroCount + 1
        'S'il y a au moins un doublons sur la ligne ou colonne ou quadrant de la cellule non vide v (isunique=false), alors on la colorie zn rouge
1        If Not IsUnique(v, Plage) Then v.Interior.Color = 255 And Count = Count + 1
    End If
Next v
If Count < 1 And zeroCount < 1 Then MsgBox ("félicitations! vous avez completer le tableau")
Set Plage = Nothing
End Sub

Merci encore

Projet Sudoku débutant

Macros et VBA Excel

Vue hybride

Discussions similaires

Partager

Partager