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