'———————————————————————————————————————————————————————————————————————————————————————————————————————————————— ' 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
Vous n’avez pas trouvé la réponse que vous recherchez ?
Posez votre questionApplication.ScreenUpdating = False Application.Calculation = xlCalculationManualet à la fin pour rétablir les calculs et l'actualisation de l'affichage
Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True