SUDOKU-Formatage grille sous VBA

Question

Bonjour,
Je cherche de l'aide en VBA sur Excel. Je connais plutôt bien Excel que je pratique depuis 30 ans, mais pas VBA.
Je me suis intéressé au SUDOKU et je suis au niveau 9. Je ne recherche pas de programme de résolution de grille (on en trouve beaucoup sur Internet) mais je cherche à mettre en forme de manière automatisée des grilles que je trouve sur internet et que je mets sur Excel afin de les imprimer dans une taille plus grande que les magazines vendus en kiosque, afin de les résoudre de manière classique.
Pour résoudre une grille, j’identifie pour chaque cellule vide les candidats potentiels et je les écris au crayon. Ce qui m'amène à 2 méthodes:
-	J’écris les chiffres à la suite des uns des autres dans chaque case vide, mais ce n’est pas visuel, donc moins efficace.
-	Dans chaque case vide, je les écris en 3 lignes de 3 chiffres de manière à ce que les chiffres potentiels soient toujours situés au même endroit dans la case (le 1 en haut à gauche, le 2 à sa droite, le 3 en haut à droite, le 4 à gauche de la seconde ligne, etc... pour finir avec le 9 en bas à droite). C'est beaucoup plus visuel mais ça fait des petits chiffres et ce n’est pas toujours bien ordonné. C’est pour ça que je voudrais formater mes cases vides pour avoir un guide.
J’imagine le principe suivant :
-	Je divise chacune des 81 cases Sudoku en 9 cases plus petites (3 lignes et 3 colonnes) J'ai donc une grille de 729 cases.
-	Je fusionne chaque ensemble de 9 cases (dans chacune des 81 cases sudoku) pour une facilité de saisie. Ça me ramène à une apparence de 81 cases.
-	A ce stade, j’ai ma grille « master » vide.
-	Je saisis les chiffres de la grille choisie sur Internet (comportant un peu plus de 20 chiffres en général)
-	Dans chaque case sans chiffre, je dé-fusionne les 9 cases et je formate en gris clair les bordures internes des 9 cases. Comme cela, lorsque j’imprime la grille, j’ai une trame dans chaque case vide qui me permet d’écrire mes candidats potentiels avec précision.
C’est pour ce travail de dé-fusionnage/bordures –pour lequel je n’ai pas trouvé de fonctions Excel, même en formatage conditionnel- que je souhaite utiliser VBA. Je peux le faire manuellement, mais c’est laborieux et peu satisfaisant intellectuellement !

Voilà, j’espère que c’est assez clair. Merci à celles et ceux qui pourront m’apporter la lumière !

Patrice33740 · Answer

Bonjour,

Essaies ce code à placer dans un module standard d'un fichier vierge :

'————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' Module    : SudokuGermain
' Objet     : Grille de sudoku
'
' Historique succint
' Date        Developpeur         Version  Action                                       Macro
'————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' 17/12/18    Patrice33740        V1-0-00  Création                                     SudokuGermain
'
Option Explicit
'
Private Const NomFeuille As String = "Sudoku"          'Nom de la feuille
Private Const EcartVertical As Integer = 30            'Nombre de lignes entre 2 grilles
Private Const EcartHorizontal As Integer = 38          'Nombre de colonnes entre 2 grilles
Private Const LigneDeDebut As Integer = 4              'N° ligne de début de la grille 1
Private Const ColonneDeDebut As Integer = 6            'N° colonne de début de la grille 1
Private Const NbreDeGrilles As Integer = 6             'Nombre de grilles
'
'Disposition des grilles (2 grilles par feuille en portrait)
' 1  3  5
' 2  4  6
' 7  9 11
' 8 10 12
'13 ...
'...
'

Private Sub RazSudoku()
' Crée une feuille de résolution du sudok
'
' Date        Developpeur         Version  Action                                       Macro
'————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' 17/12/18    Patrice33740        V1-0-00  Création                                     RazSudoku
'
If ActiveWorkbook.Name <> ThisWorkbook.Name Then Exit Sub

Dim FlgFeuilleAbsente As Boolean         'Flag feuille de calcul absente
Dim Feuille As Excel.Worksheet           'Feuille de calcul
Dim Abcisse As Double                    'Position horizontale du bouton
Dim N° As Integer                        'Numéro

'Raz feuille
'***********
'chercher la feuille
FlgFeuilleAbsente = True
For Each Feuille In Worksheets
  If Feuille.Name = NomFeuille Then FlgFeuilleAbsente = False
Next Feuille
If FlgFeuilleAbsente Then
  'Ajouter la feuille manquante
  Set Feuille = Worksheets.Add(After:=Worksheets(1))
  Feuille.Name = NomFeuille
Else
  'Effacer la feuille existante
  Sheets(NomFeuille).Select
  ActiveSheet.Cells.Delete
End If
ActiveWindow.DisplayGridlines = False

'Taille des cellules
'*******************
ActiveSheet.Rows.RowHeight = 12#
ActiveSheet.Columns.ColumnWidth = 1.57

'Boutons
'*******
N° = 0
ActiveSheet.Buttons.Delete
N° = N° + 1: Abcisse = N° * 72 - 48
ActiveSheet.Buttons.Add(Abcisse, 0, 60, 18).OnAction = "RazSudoku"
ActiveSheet.Buttons(N°).Characters.Text = "RàZ"
N° = N° + 1: Abcisse = N° * 72 - 48
ActiveSheet.Buttons.Add(Abcisse, 0, 60, 18).OnAction = "Fusionner"
ActiveSheet.Buttons(N°).Characters.Text = "Fusion"
N° = N° + 1: Abcisse = N° * 72 - 48
ActiveSheet.Buttons.Add(Abcisse, 0, 60, 18).OnAction = "DeFusionner"
ActiveSheet.Buttons(N°).Characters.Text = "Dé-Fusion"

'Mise en place des grilles
'*************************
Call Fusionner

End Sub

Private Sub Fusionner(Optional Fusion As Boolean = True)
' Fusionne.Défusionne chaque case de chaque grille et définit les contours
'
' Date        Developpeur         Version  Action                                       Macro
'————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' 17/12/18    Patrice33740        V1-0-00  Création                                     Fusionner
'
Dim Ln As Integer                        'Compteur ligne
Dim Cn As Integer                        'Compteur colonne
Dim N° As Integer                        'Numéro

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

For N° = 0 To NbreDeGrilles - 1
  Cn = ColonneDeDebut + Int((N° Mod 6) / 2) * EcartHorizontal
  Ln = LigneDeDebut + Int(N° / 6) * EcartVertical * 2
  If (N° Mod 2) = 1 Then Ln = Ln + EcartVertical
  Call ContourGrille(Cn, Ln, Fusion)
Next N°

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

End Sub

Private Sub DeFusionner()
   Call Fusionner(False)
End Sub

Private Sub ContourGrille(ByVal GrilleX As Integer, ByVal GrilleY As Integer, _
                          Optional ByVal Fusionner As Boolean = False)
' Dessine les contours d'une grille et fusionne éventuellement les cellules de chaque case.
'
' Arguments : GrilleX             [in]  Abcisse de la grille
'             GrilleY             [in]  Ordonnée de la grille
'             Fusionner           [in]  Fusion des cellules de chaquer case
'
' Date        Developpeur         Version  Action                                       Macro
'————————————————————————————————————————————————————————————————————————————————————————————————————————————————
' 17/12/18    Patrice33740        V1-0-00  Création                                     ContourGrille
'
Dim Ln As Integer                        'Compteur ligne
Dim Cn As Integer                        'Compteur colonne

'Bordures pointillés
Range(Cells(GrilleY, GrilleX), Cells(GrilleY + 26, GrilleX + 26)).Borders.Weight = xlHairline
'Bordures fines et fusion/d"fusion
For Cn = GrilleX To GrilleX + 26 Step 3
  For Ln = GrilleY To GrilleY + 26 Step 3
    'Bordures
    Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Borders(xlEdgeTop).Weight = xlThin
    Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Borders(xlEdgeLeft).Weight = xlThin
    Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Borders(xlEdgeRight).Weight = xlThin
    Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Borders(xlEdgeBottom).Weight = xlThin
    'Fusion
    If Fusionner Then
      Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).MergeCells = True
      Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).HorizontalAlignment = xlCenter
      Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).VerticalAlignment = xlCenter
      Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Font.Size = 20
      Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Font.Bold = True
    Else
      If Cells(Ln, Cn).Formula = "" Then
        Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).MergeCells = False
        Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Font.Size = 10
        Range(Cells(Ln, Cn), Cells(Ln + 2, Cn + 2)).Font.Bold = False
      End If
    End If
  Next Ln
Next Cn
'Bordures épaisses
For Cn = GrilleX To GrilleX + 24 Step 9
  For Ln = GrilleY To GrilleY + 24 Step 9
    Range(Cells(Ln, Cn), Cells(Ln + 8, Cn + 8)).Borders(xlEdgeTop).Weight = xlThick
    Range(Cells(Ln, Cn), Cells(Ln + 8, Cn + 8)).Borders(xlEdgeLeft).Weight = xlThick
    Range(Cells(Ln, Cn), Cells(Ln + 8, Cn + 8)).Borders(xlEdgeRight).Weight = xlThick
    Range(Cells(Ln, Cn), Cells(Ln + 8, Cn + 8)).Borders(xlEdgeBottom).Weight = xlThick
  Next Ln
Next Cn

End Sub

Fichier exemple :
https://mon-partage.fr/f/vw7PrZgN/

Mode d'emploi :
RàZ : Crée une feuille avec les boutons et les grilles à remplir (dans ce cas 6 grilles définies par NbreDeGrilles, soit 2 grilles par feuille A4)
Fusion : Fusionne les 9 cellules de chaque case
Dé-fusion : Défusionne les 9 cellules de chaque case non renseignée

Germain64121 · Answer

Bonjour Patrice,
Merci pour tes efforts
J'ai téléchargé ton fichier mais lors de l'ouverture, Excel (2010) bloque à 71% et me dit fichier corrompu.
J'ai copié collé ton code mais lorsque je lance la macro, rien ne se passe.
C'est probablement moi qui fais une mauvaise manip. Je vais me remettre à l'ouvrage et surtout tenter de comprendre le code que tu as écrit! (c'est ça qui est intéressant finalement).
Merci encore et bon Noël!
Germain

Germain64121 · Answer

La aussi, le fichier téléchargé est 'corrompu' et ne peut pas être ouvert par Excel.

Pour l'option de copie de code sur feuille vierge:
Dans Excel, j'ai activé les macros, j'ai ouvert 'Visual Basic', puis 'insertion', puis 'module' et j'y ai copié ton code.
J'ai cliqué sur 'fermer et retourner à Microsoft Excel'.
Sur la feuille, je n'ai rien et lorsque je veux ouvrir les macros, la liste ne contient rien.
J'enregistre bien en xlsm.
Ai-je loupé une étape d'enregistrement de macro?

Germain64121 · Answer

Bonjour Patrice
Je viens de passer quelques jours difficiles.... à me plonger dans VBA!! J'ai bien fait de la programmation il y a plus de 30 ans, mais c'est parti loin et j'ai transpiré! 
J'ai tenté de faire du "reverse engineering" de ton code, mais c'est ardu, surtout quand on n'est pas familier avec les syntaxes.
En m’inspirant de ce que tu as écrit -qui a été le déclencheur- des codes trouvés sur internet et en me basant sur le code des macro qui me donnaient ce que je cherchais, j'ai enfin écrit quelque chose qui marche. C'est quelquefois un peu lent dans certaines boucles -au point que "Excel ne répond plus" s'affiche de temps à autre pour 10-15s, mais revient finir sa boucle. 
Je te remercie de ton aide et te souhaite une bonne année!
Germain

Patrice33740 · Answer

Bonjour Germain.

Content que tu aie pu écrire ton propre code.

Avec VBA, en particulier lorsqu'on lorsqu'on utilise des boucles, ce qui ralenti Excel, c'est la mise à jour permanente de l'affichage et le recalcul des feuille à chaque modification de cellule.
C'est pour cela qu'avant les boucles j'ai mis :
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
et à la fin pour rétablir les calculs et l'actualisation de l'affichage
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Bonne continuation, n'hésites pas à revenir sur le Forum.

Je te souhaite aussi une Bonne Année 2019

SUDOKU-Formatage grille sous VBA

5 réponses

Votre réponse