voila je fait un TD de prog sur un log pour résoudre les sudoku
j'ai un problème avec des variable globale qui se comporte comme non déclaré quand je les utilise dans le module concerné
mais comme je suis loin d'être un pro en prog et encore moins dans ce langage en carton patte
j'ai besoin d'un peu d'aide
worksheet Sudoku
CODE :
Option Explicit
Dim Index As Integer, NbreValeur
Dim Sdk As Range
Dim Np As Range
'*****************************************
' Lien Interface Public
'*****************************************
Private Sub CB_Manuel_Click()
Frm_initialisation.Visible = True
Frm_Resolution.Visible = False
If Index <> 0 Then
Sdk.Item(Index) = TB_Manuel
End If
End Sub
Private Sub CB_Swap_Click()
If ActiveSheet.Name = "Pile" Then
Sheets("Sudoku").Select
CB_Swap.Caption = "Voir Feuil Pile"
Else
Sheets("Pile").Select
CB_Swap.Caption = "Voir Feuil Sudoku"
End If
Call SB_Ligne_Change
End Sub
Private Sub Frm_Resolution_Click()
End Sub
Private Sub SB_Ligne_Change()
Select Case ActiveSheet.Name
Case "Pile":
Index = SB_Ligne.Value
ActiveSheet.Cells(Index, 1).Select
Case "Sudoku":
'Call NoCadre(Sdk.Item(Index))
'Call NoCadre(Np.Item(Index))
Call BordureSudoku(Sdk)
Call BordureSudoku(Np)
Index = SB_Ligne.Value
Call Encadre(Sdk.Item(Index), 7)
Call Encadre(Np.Item(Index), 7)
End Select
End Sub
Private Sub UserForm_Initialize()
Dim Sudoku, Pil
Set Sudoku = Sheets("Sudoku")
Set Pil = Sheets("Pile")
Set Sdk = Sudoku.Range(Sudoku.Cells(1, 1), Sudoku.Cells(9, 9))
Set Np = Sudoku.Range(Sudoku.Cells(1, 15), Sudoku.Cells(9, 23))
OB_Singlette.Visible = False
CkB_PasaPas = True
Index = 0
NbreValeur = 81
Frm_Resolution.Visible = False
Frm_Pile.Visible = False
Frm_initialisation.Visible = False
End Sub
'*****************************************
' TP 2
'*****************************************
'*****************************************
' Prive
'*****************************************
Sub NoCadre(r As Range)
r.Borders(xlDiagonalDown).LineStyle = xlNone
r.Borders(xlDiagonalUp).LineStyle = xlNone
r.Borders(xlEdgeLeft).LineStyle = xlNone
r.Borders(xlEdgeTop).LineStyle = xlNone
r.Borders(xlEdgeBottom).LineStyle = xlNone
r.Borders(xlEdgeRight).LineStyle = xlNone
r.Borders(xlInsideVertical).LineStyle = xlNone
r.Borders(xlInsideHorizontal).LineStyle = xlNone
End Sub
Sub Encadre(r As Range, COULEUR As Integer)
' r.Borders(xlDiagonalDown).LineStyle = xlNone
' r.Borders(xlDiagonalUp).LineStyle = xlNone
'COULEUR = 7
With r.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = COULEUR
End With
With r.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = COULEUR
End With
With r.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = COULEUR
End With
With r.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.Weight = xlMedium
.ColorIndex = COULEUR
End With
End Sub
Sub BordureSudoku(zone As Range)
Dim r As Range, i As Integer, j As Integer
Call NoCadre(zone)
For i = 1 To 7 Step 3
For j = 1 To 7 Step 3
Set r = zone.Range(Cells(i, j), Cells(i + 2, j + 2))
Call Encadre(r, 1)
Next j
Next i
End Sub
'*****************************************
' TP 2
'*****************************************
'Outils de transfert'
Public Sub Copyfeuil(Source As String, Cible As String)
Sheets(Source).Activate
Sheets(Source).Range(Cells(1, 1), Cells(9, 9)).Copy
Sheets(Cible).Activate
Sheets(Cible).Cells(1, 1).Select
Sheets(Cible).PasteSpecial
End Sub
Private Sub CB_Import_Click()
Dim Source As String
Source = InputBox("feuille à importer", "Import", "Ex 1")
Call Copyfeuil(Source, "Sudoku")
Frm_Pile.Visible = True
End Sub
Private Sub CB_Export_Click()
Dim Cible As String
Cible = InputBox("feuille dans laquelle exporter", "Export", "Ex 1")
Call Copyfeuil("Sudoku", Cible)
End Sub
'interface pour suprimer toute la BDD'
Private Sub CB_DeleteAllPile_Click() '
Pile.Delete_All_Pile
Np.ClearContents
End Sub
'interface qui remplit tout le BDD'
Private Sub CB_Crea_Pile_Click()
Dim i As Integer
For i = 1 To Np.Count
Np.Item(i) = Pile.Init_New_Pile(9)
Next i
Frm_Pile.Visible = False
Frm_initialisation.Visible = True
Sheets("sudoku").Activate
End Sub
'Next case pleine'
Public Function Next_Case_Pleine() As Boolean 'recherche une case pleine et renvois qu'il a trouvé'
Next_Case_Pleine = True
Do
Index = Index + 1
Loop Until Not IsEmpty(Sdk.Item(Index)) Or Index > 81
'cache et affiche des zones'
Frm_Resolution.Visible = True
Frm_initialisation.Visible = False
If Index > 81 Then
Next_Case_Pleine = False
Index = 0
End If
End Function
'Purge zone'
Public Sub purge_zone() 'à pour fonction de suprimer la valeur de la case dans toutes les zones concernées'
Sheets("Pile").Activate
Dim Valeur As Integer
Dim i As Integer
Dim j As Integer
Dim ii As Integer
Dim jj As Integer
Dim z As Range
i = Int(Index / 9) + 1 'ordonné de la case'
j = Index - (i - 1) * 9 'absice de la case'
ii = (Int((i - 1) / 3) * 3) + 1 'absice de la casse haute gauche du carré'
jj = (Int((j - 1) / 3) * 3) + 1 'ordonné de la casse haute gauche du carré'
Valeur = Sdk.Item(Index) 'valeur a oter des zones'
Call Pile.Vide_Pile(Index)
Set z = Np.Range(Cells(i, 1), Cells(i, 9)) 'définit et calcule z comme ligne contenant la cellule'
Call Sudoku.purge_une_zone(z, Valeur)
Set z = Np.Range(Cells(1, j), Cells(9, j)) 'définit et calcule z comme collone contenant la cellule'
Call Sudoku.purge_une_zone(z, Valeur)
Set z = Np.Range(Cells(ii, jj), Cells(ii + 2, jj + 2)) 'définit et calcule z comme carre contenant la cellule'
Call Sudoku.purge_une_zone(z, Valeur)
End Sub
'Purge une zone'
Public Sub purge_une_zone(zozo As Range, Valeur As Integer) 'suprime la veleur dans UNE zone'
Dim NumP As Integer
Dim i As Integer
For i = 1 To zozo.Count
NumP = zozo.Item(i)
Call Pile.Depile_Valeur(NumP, Valeur)
Next i
End Sub
'Initialisation Sudoku'
Public Sub Initialisation_SDK()
Dim boucle As Boolean
boucle = False '
Do While Next_Case_Pleine And Not boucle
Call purge_zone
boucle = CkB_PasaPas
Loop
End Sub
Private Sub CB_ExecInit_Click()
Call Initialisation_SDK
End Sub
worksheet pile
CODE :
Option Explicit
Dim Index As Integer, NbreValeur, Sdk As Range, Np As Range
'declaration '
Dim New_ligne As Integer
'initialisation de new line'
Private Sub UserForm_Initialize()
New_ligne = 1
Do While Not IsEmpty(Sheets("Pile").Cells(New_ligne, 1))
New_ligne = New_ligne + 1
Loop
End Sub
'programme new pile'
'crée une pile à la suite avec une taile de pille egale à T'
Public Function Init_New_Pile(T As Integer) As Integer
Dim i As Integer
Sheets("Pile").Cells(New_ligne, 1) = T
For i = 1 To T
Sheets("Pile").Cells(New_ligne, i + 1) = i
Next i
Init_New_Pile = New_ligne
New_ligne = New_ligne + 1 'incremente new_ligne qui sert à savoir ou créer la prochaine pile'
End Function
'programme nettoie tout'
'vide tout la BDD'
Public Sub Delete_All_Pile()
Dim zone_a_effacer As Range
Sheets("Pile").Activate
Set zone_a_effacer = Sheets("Pile").Range(Cells(1, 1), Cells(New_ligne, 10))
zone_a_effacer.ClearContents
New_ligne = 1
End Sub
'Programme vide pile'
'sert à vider une pile et à metre son nombre de posibilitée à 0'
Public Sub Vide_Pile(blabla As Integer)
Dim zone_a_effacer As Range
Set zone_a_effacer = Sheets("Pile").Range(Cells(blabla, 2), Cells(blabla, 10))
zone_a_effacer.ClearContents
Sheets("Pile").Cells(blabla, 1) = 0
End Sub
'Programme Depile Valeur'
'sert à suprimer une valeur Vl à une pile NumP'
Public Sub Depile_Valeur(NumP As Integer, Vl As Integer)
Dim i As Integer
Dim j As Integer
i = 2
Do While (Int(Vl) <> Sheets("Pile").Cells(NumP, i))
i = i + 1
Loop
For j = i To Sheets("Pile").Cells(TB_Vide_Pile, 1) + 1
Sheets("Pile").Cells(NumP, j) = Sheets("Pile").Cells(NumP, j + 1)
Next j
Sheets("Pile").Cells(NumP, 1) = Sheets("Pile").Cells(NumP, 1) - 1
End Sub
Message édité par oksaux le lundi 22 décembre 2008 à 03:38:55