Discussion :

[Estelle77]

Bonjour,

je souhaiterai créer une matrice qui contient toutes les combinaisons vérifiant les contraintes suivantes :

- x est le nombre de colonne (x est choisit par l'utilisateur)
- 1 point de la matrice est compris entre 0 et 1 avec un pas donné (imposé par l'utilisateur)
- la somme de tous les points d'une même ligne doit être égale exactement à 1

Par exemple, j'aimerai que quadri(4, 0.5) où x = 4 et pas = 0.5 donne le résultat :
1 0 0 0
0.5 0.5 0 0
0 1 0 0
0.5 0 0.5 0
0 0.5 0.5 0
0 0 1 0
0.5 0 0 0.5
0 0.5 0 0.5
0 0 0.5 0.5
0 0 0 1

ou quadri (3,0.25) devra donner le résultat :
1 0 0
0.75 0.25 0
0.5 0.5 0
0.25 0.75 0
0 1 0
0.75 0 0.25
0.5 0.25 0.25
0.25 0.5 0.25
0 0.75 0.25
0.25 0.25 0.5
0.5 0 0.5
0 0.5 0.5
0.25 0 0.75
0 0.25 0.75
0 0 1

Je pense qu'il faut utiliser une macro récursive mais je n'arrive pas à la construire. Pouvez-vous m'aider à construire l'algorithme ?


je développe sous Visual Basic 6.3 qui fait partie de Excel 2003. Je n'arrive pas à créer une macro sortant la matrice que je souhaite. J'ai l'impression que la solution passe par une fonction récursive pour optimiser l'algorithme mais je me prend la tête sur la macro depuis hier et je n'ai encore rien sorti de convenable.

Pouvez-vous m'aider ?

[patbou]

bonjour,

voici un code qui permet d afficher toutes les combinaison de n parmis p

auteur :'Myrna Larson, Frédéric Sigonneau, Serge Garneau


Option Explicit

'Voici une diabolique procédure pour mettre
'définitivement fin aux questions concernant les
'listes de combinaisons ou de permutations
'de R éléments choisis parmi N.
'Pour l 'utiliser :
'1. En A1, écrire c ou p ; (Combinaison ou Permutation)
'2. En A2, écrire la valeur de R ;
'3. Sous A2, écrire la liste des N éléments ;
'4. Sélectionner A1 et activer la procédure.

'Exemple:
'A1 c
'A2 3
'A3 1
'A4 2
'A5 Excel
'A6 4
'A7 *
'A8 6

'La procédure donne alors la liste de toutes les combinaisons
'possibles de 3 éléments choisis parmi 6.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
 
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
 
Sub ListPermutations()
Dim Rng As Range
Dim PopSize As Integer 'nb d 'élements
Dim SetSize As Integer ' ensemble
Dim Which As String
Dim n As Double
Const BufferSize As Long = 4096
 
Set Rng = Selection.Columns(1).Cells
If Rng.Cells.Count = 1 Then
Set Rng = Range(Rng, Rng.End(xlDown)) ' selection de la plage
End If
 
PopSize = Rng.Cells.Count - 2 'nb d elements
If PopSize < 2 Then GoTo DataError
 
SetSize = Rng.Cells(2).Value 'nb d elem choisis
If SetSize > PopSize Then GoTo DataError
'selection combin ou permut + controle nb element < nb de ligne
Which = UCase$(Rng.Cells(1).Value)
Select Case Which
Case "C"
n = Application.WorksheetFunction.Combin(PopSize, SetSize)
Case "P"
n = Application.WorksheetFunction.Permut(PopSize, SetSize)
Case Else
GoTo DataError
End Select
If n > Cells.Count Then GoTo DataError
 
Application.ScreenUpdating = False
 
Set Results = Worksheets.Add
 
vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
 
ReDim Buffer(1 To BufferSize) As String
BufferPtr = 0
 
If Which = "C" Then
AddCombination PopSize, SetSize
Else
AddPermutation PopSize, SetSize
End If
vAllItems = 0
 
Application.ScreenUpdating = True
Exit Sub
 
DataError:
If n = 0 Then
Which = "Enter your data in a vertical range of at least 4 cells. " _
& String$(2, 10) _
& "Top cell must contain the letter C or P, 2nd cell is the number" _
& "of items in a subset, the cells below are the values from which" _
& "the subset is to be chosen."
Else
Which = "This requires " & Format$(n, "#,##0") & _
" cells, more than are available on the worksheet!"
End If
MsgBox Which, vbOKOnly, "DATA ERROR"
Exit Sub
End Sub
 
Private Sub AddPermutation(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0)
 
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Static Used() As Integer
Dim i As Integer
 
If PopSize <> 0 Then
iPopSize = PopSize 'nb elem
iSetSize = SetSize 'nb d elem choisi
ReDim SetMembers(1 To iSetSize) As Integer 'tableau des elem choisi
ReDim Used(1 To iPopSize) As Integer 'tableau representant l ens des elem
NextMember = 1
End If
 
For i = 1 To iPopSize 'on boucle sur ts les elements
If Used(i) = 0 Then
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
Used(i) = True
AddPermutation , , NextMember + 1
Used(i) = False
Else
SavePermutation SetMembers()
End If
End If
Next i
 
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
Erase Used
End If
 
End Sub 'AddPermutation
 
Private Sub AddCombination(Optional PopSize As Integer = 0, _
Optional SetSize As Integer = 0, _
Optional NextMember As Integer = 0, _
Optional NextItem As Integer = 0)
 
Static iPopSize As Integer
Static iSetSize As Integer
Static SetMembers() As Integer
Dim i As Integer
 
If PopSize <> 0 Then
iPopSize = PopSize
iSetSize = SetSize
ReDim SetMembers(1 To iSetSize) As Integer
NextMember = 1
NextItem = 1
End If
 
For i = NextItem To iPopSize
SetMembers(NextMember) = i
If NextMember <> iSetSize Then
AddCombination , , NextMember + 1, i + 1
Else
SavePermutation SetMembers()
End If
Next i
 
If NextMember = 1 Then
SavePermutation SetMembers(), True
Erase SetMembers
End If
 
End Sub 'AddCombination
 
Private Sub SavePermutation(ItemsChosen() As Integer, _
Optional FlushBuffer As Boolean = False)
 
Dim i As Integer, sValue As String
Static RowNum As Long, ColNum As Long
 
If RowNum = 0 Then RowNum = 1
If ColNum = 0 Then ColNum = 1
 
If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
If BufferPtr > 0 Then
If (RowNum + BufferPtr - 1) > Rows.Count Then
RowNum = 1
ColNum = ColNum + 1
If ColNum > 256 Then Exit Sub
End If
 
Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
= Application.WorksheetFunction.Transpose(Buffer())
RowNum = RowNum + BufferPtr
End If
 
BufferPtr = 0
If FlushBuffer = True Then
Erase Buffer
RowNum = 0
ColNum = 0
Exit Sub
Else
ReDim Buffer(1 To UBound(Buffer))
End If
 
End If
 
'construct the next set
For i = 1 To UBound(ItemsChosen)
sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
Next i
 
'and save it in the buffer
BufferPtr = BufferPtr + 1
Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub
'SavePermutation

donc il ne te reste plus qu a definir l ensemble des pas possible

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
 
Function tabl_possibilté(nb As Single) As Variant
Dim i As Integer, j As Integer
If 1 Mod nb <> 0 Then
MsgBox "nbre non divisible"
Exit Function
Else
i = 1 / nb
For j = 0 To i
tabl_possibilté(j) = i * j
Next j
End If
End Function

puis a calculer la somme de toute les combinaisons

[Montor]

il y a des changements
n = 0.25 votre ref
colcunt = 3 nombre de colonne
Executer la sub "Matrix"

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

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
Sub folw(Ope, Refs, Outs, Ov, Sys, lasts)
If Ov Then
If Ope + Refs > Sys Then
Outs = lasts
Ov = True
Else
Outs = Ope + Refs
Ov = False
End If
Else
Ov = False
Outs = Ope
End If
End Sub
 
Sub matrix()
n = 0.25
colcunt = 3
 
 
colsinc = 1
ReDim units(colcunt)
units(0) = 1
For ffc = 1 To colcunt - 1
units(ffc) = 0
Next ffc
While (units(colcunt - 1) <> 1)
v = True
If ss > 1 Or ss < 0 Then
units(0) = "err"
Else
For ffc = 0 To colcunt - 1
units(0) = 1 - ss
Cells(colsinc, ffc + 1) = units(ffc)
Next ffc
colsinc = colsinc + 1
End If
ss = 0
For ddd = 1 To colcunt - 1
If ddd = colcunt - 1 Then
islast = 1
Else
islast = 0
End If
Call folw(units(ddd), n, uu, v, 1, islast)
units(ddd) = uu
ss = ss + uu
Next ddd
Wend
End Sub

[Estelle77]

Génial. Je vous remercie beaucoup pour votre aide.

Merci beaucoup pour le temps que vous avez passé à résoudre ce casse-tête. Je n'arrivais vraiment pas à trouver la solution.