visual basic sous exel

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

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