Créer un jeu pour l'été

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion C@thy
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
C@thy

C@thy

XLDnaute Barbatruc
Quelqu'un connaît le Takuzu?

C'est une grille de 10x10 (ou moins pour les enfants, mais on va dire 10x10)
sur chaque ligne doivent se trouver autant de 0 que de 1 (= 5 de chaque)
pareil pour les colonnes
il ne doit pas y avoir plus de 2 0 ou 1 qui se suivent, en ligne ou en colonne

le but du jeu c'est de créer des grilles automatiques, en partie pré-remplies comme dans l'exemple joint

et aussi le solver permettant de les résoudre...

p'têt que ça existe, mais sans doute pas sous Excel

Y a-t-il un super programmeur ou un super formuliste (pour la partie résolution de grille) intéressé???

Bises à vous et bon courage!😉

C@thy
 

Pièces jointes

Trier par date Trier par votes
Re : Créer un jeu pour l'été

Bonsoir Cathy,

Un premier essai pour la résolution bête et méchante. Je crois, sauf erreur, que la grille fournie est une grille impossible (merci... 😱). Pas facile de trouver des grilles sur le net ! J'en ai trouvée une de 8*8 que j'ai mise dans le classeur joint. Les colonnes M, N et lignes 12, 13 ne servent qu'à vérifier le résultat, elles peuvent être supprimées. Pas de souci donc avec cette grille mais il faudrait multiplier les essais pour voir si d'autres tests seraient nécessaires à une résolution à tout coup. Cordialement

KD

VB: 
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
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Créer un jeu pour l'été

Bonjour Cathy, KenDev

Si j'ai bien compris, ci joint la grille de cathy renseignée mais manuellement.

Edit: Oups mal compter le nb de zero et de un, correction en cours
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Créer un jeu pour l'été

Bonjour les amis et merci pour tous vos efforts,
oui cette grille a bien une solution
je pensais a la resoudre avec des formules, un peu comme le sudoku de Jean-Marie
et plus tard son samourai (super sudoku : 5 grilles imbriquées)
toute soluce, macro ou formes est bonne à prendre
Merci à vous et bises depuis Toulouse ou je viens d'atterrir
 
Vote positif 0 Vote négatif
Re : Créer un jeu pour l'été

Bonjour Cathy, Piga,

Je suis en désaccord avec ta résolution Piga puisqu'à partir de l'étape jaune tu fais des 'choix libres'. Toutefois tu arrives à une solution correcte. J'ai également complété à la main la grille proposée et j'arrive à une autre solution. (voir fichier joint)

La grille de départ a donc au moins deux solutions, c'est suffisant pour affirmer qu'elle est incorrecte. Ou alors le jeu perd tout son intérêt à mon sens.

Je reste donc en atttente d'autres grilles, ou de liens vers d'autres grilles, pour tester la résolution par macro (mis à part la grille de 8*8 testée favorablement je n'ai trouvé que des liens vers des logiciels à installer, ce que je souhaite éviter).

Cordialement

KD
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Créer un jeu pour l'été

Re,

Je ne sais comment je me suis débrouillé lors du post 3 mais la macro non modifiée arrive bien à la solution du post 9 pour la grille de départ de Cathy... 😕 Toutefois ça ne résout pas la question des solutions multiples... Pas de spécialistes de ce jeu par ici ? Cordialement

KD
 
Vote positif 0 Vote négatif
Re : Créer un jeu pour l'été

Bonjour à tous

Avant de regarder en detail vos posts:
Ma version dont je ne garantis pas qu'elle fonctionne pour tous les problemes
Par contre je suis sur qu'elle ne trouvera pas toutes les solutions

Je suis de l'avis de Kendev concernant la solution de piga d'autant qu'en B2 B3 B4 trois 0 se suivent

En sus je constate que ta solution KenDev est strictement conforme a celle a laquelle aboutit mon brouillon de macro
 

Pièces jointes

Dernière édition:
Vote positif 0 Vote négatif
Re : Créer un jeu pour l'été

Re et bonjour PierreJean,

Nos deux macros trouvent la même solution et je n'avais pas vu les trois 0 dans la solution de Piga. Du coup cette solution est sans doute unique (?). Donc mes excuses, en particulier à Cathy, pour la confusion dans ce fil. La grille de départ est bien correcte comme elle nous l'a dit dès le départ. 😱

Reste à générer maintenant des grilles... Cordialement

KD
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

Lu76Fer
  • Résolu(e)
XL 2016 Démo pour positionner un UserForm ou ContextMenu sur la grille (Toute version)
10 11 12
Réponses
178
Affichages
9 K
TooFatBoy
TooFatBoy
C@thy
  • Question Question
Créer un jeu pour l'été VBA
2
Réponses
20
Affichages
4 K
C@thy
C@thy
B
  • Question Question
macro pour attribuer un jeu de couleur
Réponses
1
Affichages
1 K
tototiti2008
tototiti2008
C@thy
  • Question Question
VBA Transformer un tableau
Réponses
10
Affichages
1 K
BOISGONTIER
BOISGONTIER
C@thy
  • Question Question
Nouveau jeu pour l'été
Réponses
5
Affichages
2 K
C@thy
C@thy
Retour