Recuit simulé

Version imprimable

05/01/2013, 01h54
farhany-daoud

Recuit simulé

Bonjour tout le monde.
Je suis bloqué dans la réalisation d'un devoir en sodoku en VBA Excel :cry: avec la méthode recuit simulé.
Si quelqu'un peut m'aider... merci d'avance .
25/01/2019, 14h10
debutante_vb

permutation colonne

bonjour chere communauté,
j'ai un damier qui contient une solution initiale et je veux effectuer une fonction qui permute 2 colonnes si de dames se trouvent dans la meme diagonale
si quelqu'un peut m'aider
nb: la fonction doit effectuer une seul transformation
j'espère que ma question est claire
par exemple j'ai
R 0 0 0
0 R 0 0
0 0 R 0
0 0 0 R
la fonction doit retourner
0 R 0 0
R 0 0 0
0 0 R 0
0 0 0 R

Bonjour,

A debutante_vb, une proposition:

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
Dim NbLig As Byte, NbCol As Byte, Lig As Byte, i As Byte, L As Byte, C As Byte
 
Sub Permut()
    Application.ScreenUpdating = False
    NbLig = [A100].End(xlUp).Row '
    NbCol = NbLig
 
    'Traitement de la diagonale gauche-droite
    'Ecriture de chaque valeur de la diagonale
    Cells(1, "J") = Application.WorksheetFunction.Bin2Dec(1 & Application.WorksheetFunction.Rept(0, NbCol - 1))
    For L = 2 To NbLig
        Cells(L, "J") = Cells(L - 1, "J") / 2
    Next L
 
    'Conversion binaire décimal de la grille -diagonale gauche-droite
    Lig = 1
    For L = 1 To NbLig
        ValBin = ""
        For C = 1 To NbCol
            ValBin = ValBin & Cells(L, C)
        Next C
        Cells(Lig, "K") = Application.WorksheetFunction.Bin2Dec(ValBin * 1)
        Lig = Lig + 1
    Next L
 
    For i = 1 To NbLig
        If Cells(i, "J") = Cells(i, "K") Then
            Lig = i
            For j = Lig + 1 To NbLig
                If Cells(j, "J") = Cells(j, "K") Then
                    Val1 = Cells(i, "K")
                    Val2 = Cells(j, "K")
                    Cells(i, "K") = Val2
                    Cells(j, "K") = Val1
                    Appliquer_en_binaire
                    End
                End If
            Next j
        End If
    Next i
 
    'Traitement de la diagonale droite-gauche
    'Ecriture de chaque valeur de la diagonale
    Cells(, "J") = 1
    For L = 2 To NbLig
        Cells(L, "J") = Cells(L - 1, "J") * 2
    Next L
 
    'Conversion binaire décimal de la grille -diagonale gauche-droite
    Lig = 1
    For L = 1 To NbLig
        ValBin = ""
        For C = 1 To NbCol
            ValBin = ValBin & Cells(L, C)
        Next C
        Cells(Lig, "K") = Application.WorksheetFunction.Bin2Dec(ValBin * 1)
        Lig = Lig + 1
    Next L
 
    For i = 1 To NbLig
        If Cells(i, "J") = Cells(i, "K") Then
            Lig = i
            For j = Lig + 1 To NbLig
                If Cells(j, "J") = Cells(j, "K") Then
                    Val1 = Cells(i, "K")
                    Val2 = Cells(j, "K")
                    Cells(i, "K") = Val2
                    Cells(j, "K") = Val1
                    Appliquer_en_binaire
                    End
                End If
            Next j
        End If
    Next i
End Sub
 
Sub Appliquer_en_binaire()
    'Restituer sous forme binaire
    Lig = 1
    For L = 1 To NbLig
         ValBin = Format(Application.WorksheetFunction.Dec2Bin(Cells(Lig, "K")), Application.WorksheetFunction.Rept(0, NbLig))
         For C = 1 To NbCol
            Cells(L, C) = Mid(ValBin, C, 1)
         Next C
         Lig = Lig + 1
    Next L
    Columns("J:K").ClearContents
End Sub

Avec le fichier
Pièce jointe 444665

Cdlt

29/01/2019, 13h04
debutante_vb

bonjour,
merci pour votre réponse mais cette algorithme fonctionne que pour les 2 diagonales et sauf si un seul diagonale est remplie mais je dois avoir les permutation même pour les diagonales supérieurs gauche et droite et les diagonales inférieurs
pour être plus claire je mettrais un exemple
0 R 0 0 0 0 0
0 0 R 0 0 0 0
0 0 0 R 0 0 0
0 0 0 0 R 0 0
0 0 0 0 0 R 0
0 0 0 0 0 0 R
0 0 0 0 0 0 0
deviendra
0 0 R 0 0 0 0
0 R 0 0 0 0 0
0 0 0 R 0 0 0
0 0 0 0 R 0 0
0 0 0 0 0 R 0
0 0 0 0 0 0 R
0 0 0 0 0 0 0

Bonjour,

Excusez pour la réponse tardive mais je n'étais pas disponible.
Voici la solution avec les modifs demandées

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
Option Compare Text
Dim Lig As Byte, NbLig As Byte, NbCol As Byte, n As Byte, L As Byte, i As Byte, j As Byte
Dim ValBin_A As String, ValBin_B As String
Dim Mem_A As Byte, Mem_B As Byte, Mem_C As Byte
 
Sub Permut()
    Application.ScreenUpdating = False
    NbLig = [A100].End(xlUp).Row '
    NbCol = NbLig
 
    For x = 1 To NbLig - 1
        Val_A = ""
        Multi = 2
        For y = 1 To NbCol
            Val_A = Val_A & Cells(x, y)
        Next y
        Mem_A = Application.WorksheetFunction.Bin2Dec(Val_A) * 1
        For p = x + 1 To NbLig
            Val_B = ""
            For q = 1 To NbCol
                Val_B = Val_B & Cells(p, q)
            Next q
            Mem_B = Application.WorksheetFunction.Bin2Dec(Val_B) * 1
            If Mem_A = Mem_B * Multi Or Mem_A * Multi = Mem_B Then
                If Mem_A = Mem_B * Multi Then
                    Mem_C = Mem_B
                    Mem_B = Mem_A
                    Mem_A = Mem_C
                ElseIf Mem_A * Multi = Mem_B Then
                    Mem_C = Mem_A
                    Mem_A = Mem_B
                    Mem_B = Mem_C
                End If
                ValBin_A = Format(Application.WorksheetFunction.Dec2Bin(Mem_A), Application.WorksheetFunction.Rept(0, NbLig))
                ValBin_B = Format(Application.WorksheetFunction.Dec2Bin(Mem_B), Application.WorksheetFunction.Rept(0, NbLig))
                For C = 1 To NbCol
                   Cells(x, C) = Mid(ValBin_A, C, 1)
                Next C
                For C = 1 To NbCol
                   Cells(p, C) = Mid(ValBin_B, C, 1)
                Next C
                End
            Else
                Multi = Multi * 2
            End If
        Next p
    Next x
End Sub

Le principe:
On compare la valeur binaire constituée par chaque cellule de la première ligne aux valeurs binaires constituées par chaque cellule des lignes suivantes.
Comme on recherche une valeur en diagonale, la valeur sur la ligne suivante par rapport à la première ne peut avoir qu'une valeur double ou de moitié, puis par rapport à la ligne suivante que le quadruple ou le quart, ainsi de suite.
en clair: si la ligne 1 a une valeur binaire =00100000 soit en décimal 32 la ligne 2 ne peut prendre que les valeurs 01000000 soit 64 en décimal ou bien 00010000 soit 16 en décimal
si la ligne 1 a une valeur binaire =00100000 soit en décimal 32 la ligne 3 ne peut prendre que les valeurs 10000000 soit 128 en décimal ou bien 00001000 soit 8 en décimal et ainsi de suite..
si aucune de ces conditions ne sont réunis alors on teste la 2ème avec les autres et ainsi de suite jusqu'à ce qu'on trouve une valeur sur la même diagonale.

avec le fichier
Pièce jointe 446135

cdlt