Discussion :

[ProgElecT]

Je me suis piqué au jeu.
Je n’ai pas été très longtemps à l’école, et les mathématiques, c’est déjà bien loin.
Mon approche semblera donc bien exotique, mais sa fonctionne, alors je met quand même le code.

Sur un Form, 2 CommandButtons, 2 Labels, 1 TextBox et 2 ListBoxs, (List2.Sorted = True)
Les combinaisons se retrouvent dans la variable tableau TableauFinal et affichées dans List2.

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
Option Explicit
Private Type TblIdx
 Contenu As String
 Idx As Long
End Type
Dim TableauFinal() As TblIdx
 
Private Sub Command2_Click()
Dim Provis() As String
Dim LeTableau() As TblIdx
Dim T As Long, U As Long
Dim NbrMaxiDiff As Long
Dim NbrElem As Long
Dim ChaineDeChiffrage As String
Dim TbleauChifre() As Long
Dim TxtRech As String
Dim Reponse As String
 
Reponse = Trim(InputBox("Entrez vos éléments séparés par des virgules", "Entrées éléments (Mini 2)"))
If Reponse = "" Then Exit Sub
If Left(Reponse, 1) <> "," Then Reponse = Reponse & ","
NbrElem = UBound(Split(Reponse, ","))
If NbrElem < 1 Then Beep: Exit Sub
 
ReDim LeTableau(NbrElem - 1)
Provis = Split(Reponse, ",")
 
NbrMaxiDiff = (2 ^ NbrElem) - 1
Label1 = "Nbr. de combinaison: " & NbrMaxiDiff - NbrElem & " pour " & NbrElem & " éléments."
For T = 1 To NbrMaxiDiff
 ChaineDeChiffrage = ChaineDeChiffrage & T & ","
 DoEvents
Next T
ChaineDeChiffrage = "," & ChaineDeChiffrage
 
List1.Clear 'pour debug
For T = NbrElem To 1 Step -1
 LeTableau(T - 1).Contenu = Provis(T - 1)
 LeTableau(T - 1).Idx = 2 ^ (T - 1)
 List1.AddItem LeTableau(T - 1).Contenu & "    " & LeTableau(T - 1).Idx 'pour debug
 TxtRech = "," & LeTableau(T - 1).Idx
 ChaineDeChiffrage = Replace(ChaineDeChiffrage, TxtRech, "", , 1, vbBinaryCompare)
 DoEvents
Next T
ChaineDeChiffrage = Left(ChaineDeChiffrage, Len(ChaineDeChiffrage) - 1)
ChaineDeChiffrage = Right(ChaineDeChiffrage, Len(ChaineDeChiffrage) - 1)
Provis = Split(ChaineDeChiffrage, ",")
 
 
ReDim TbleauChifre(UBound(Provis))
For T = 0 To UBound(Provis)
 DoEvents
 TbleauChifre(T) = CLng(Provis(T))
Next T
 
ReDim TableauFinal(UBound(TbleauChifre))
List2.Visible = False
List2.Clear 'pour debug
For T = 0 To UBound(TbleauChifre)
 DoEvents
 TableauFinal(T).Idx = TbleauChifre(T)
 For U = UBound(LeTableau) To 0 Step -1
  If TbleauChifre(T) >= LeTableau(U).Idx Then
   DoEvents
   TableauFinal(T).Contenu = TableauFinal(T).Contenu & " " & LeTableau(U).Contenu
   TbleauChifre(T) = TbleauChifre(T) - LeTableau(U).Idx
  End If
 Next U
 List2.AddItem TableauFinal(T).Contenu 'pour debug
Next T
List2.Visible = True
 
End Sub
 
Private Sub Form_Load()
Me.Height = 5505: Me.Width = 8295
Command1.Move 2145, 75, 645, 315: Command1.Caption = "Go"
Command2.Move 3795, 75, 4170, 315: Command2.Caption = "Autre méthode, entrez des éléments"
Label2.Move 180, 135, 1320, 195: Label2.Caption = "Nbr. d'elements =>"
Text1.Move 1575, 105, 495, 285: Text1.Text = "4"
Label1.Move 180, 465, 480, 195: Label1.Caption = "": Label1.AutoSize = True
List1.Move 135, 720, 1785, 4155: List1.Clear
List2.Move 2010, 720, 5910, 4155: List2.Clear ': List2.Sorted = True
 
End Sub
 
Private Sub Command1_Click()
Dim Provis() As String
Dim LeTableau() As TblIdx
Dim T As Long, U As Long
Dim NbrMaxiDiff As Long
Dim NbrElem As Long
Dim ChaineDeChiffrage As String
Dim TbleauChifre() As Long
Dim TxtRech As String
 
If Not IsNumeric(Text1.Text) Then
 Beep
 Exit Sub
End If
 
If Val(Text1.Text) < 2 Then
 Beep
 Exit Sub
End If
 
NbrElem = Text1
ReDim LeTableau(NbrElem - 1)
 
NbrMaxiDiff = (2 ^ NbrElem) - 1
Label1 = "Nbr. de combinaison: " & NbrMaxiDiff - NbrElem
For T = 1 To NbrMaxiDiff
 ChaineDeChiffrage = ChaineDeChiffrage & T & ","
 DoEvents
Next T
ChaineDeChiffrage = "," & ChaineDeChiffrage
 
List1.Clear 'pour debug
'le contenu pouvant être alimenté par une BD, un fichier .Txt, des entrées utilisateur ......
For T = NbrElem To 1 Step -1
 LeTableau(T - 1).Contenu = Chr(T + 64)
 LeTableau(T - 1).Idx = 2 ^ (T - 1)
 List1.AddItem LeTableau(T - 1).Contenu & "    " & LeTableau(T - 1).Idx 'pour debug
 TxtRech = "," & LeTableau(T - 1).Idx
 ChaineDeChiffrage = Replace(ChaineDeChiffrage, TxtRech, "", , 1, vbBinaryCompare)
 DoEvents
Next T
ChaineDeChiffrage = Left(ChaineDeChiffrage, Len(ChaineDeChiffrage) - 1)
ChaineDeChiffrage = Right(ChaineDeChiffrage, Len(ChaineDeChiffrage) - 1)
Provis = Split(ChaineDeChiffrage, ",")
 
 
ReDim TbleauChifre(UBound(Provis))
For T = 0 To UBound(Provis)
 DoEvents
 TbleauChifre(T) = CLng(Provis(T))
Next T
 
ReDim TableauFinal(UBound(TbleauChifre))
List2.Visible = False
List2.Clear 'pour debug
For T = 0 To UBound(TbleauChifre)
 DoEvents
 TableauFinal(T).Idx = TbleauChifre(T)
 For U = UBound(LeTableau) To 0 Step -1
  If TbleauChifre(T) >= LeTableau(U).Idx Then
   DoEvents
   TableauFinal(T).Contenu = TableauFinal(T).Contenu & " " & LeTableau(U).Contenu
   TbleauChifre(T) = TbleauChifre(T) - LeTableau(U).Idx
  End If
 Next U
 TableauFinal(T).Contenu = StrReverse(TableauFinal(T).Contenu)
 List2.AddItem TableauFinal(T).Contenu 'pour debug
Next T
List2.Visible = True
 
End Sub

La vérification de 2 à 5 éléments est correcte, après, cela devient dur quand on en a pas besoin (déjà 26 combinaisons pour 5 éléments).
Au delà de 15 éléments, il ne sont plus affichable dans le ListBox, IndexList as Integer oblige (65519 combinaisons).

[ucfoutu]

Bonjour, Progelect,
Ce n'est pas l'affichage, qui n'est pas possible (il se fait), mais le ListCount...
Il est par exemple limité, sur ma machine (Win 2000), au maximum d'un Integer (32 767)
Ma méthode parvient à afficher et compter, par exemple, 16383 "mélanges" pour 14 fruits.
Au delà, j'affiche les mélanges mais :
- le listCount ne fonctionne plus correctement
- j'entends le ventilateur de mon processeur s'activer sacrément pour refroidir ce dernier

Il est toujours possible d'ajouter un compteur typé en Long pour compter au delà, au prix toutefois d'une sollicitation de plus du processeur par itération.

[ucfoutu]

Coucou,

Hé bien non (bien que RESOLU)...

J'avais du temps pour décortiquer un peu mieux, faire mes mesures, etc...
Les split (procédure rétablissons) et Replace sont d'affreux gourmands à jeter à la poubelle sans la moindre hésitation.
Je reprends donc exactement le même mécanisme, en traitant "en chemin et en avant" la transposition en fruits...
Et, bien entendu, je "jette" la procédure retablissons.

Résultat ?
durée d'exécution divisée par un peu plus de 3 !

C'est peu significatif sur une petit nombre de fruits, mais vachement visible sur un plus grand nombre (moins d'une seconde pour traiter les coktails de 10 fruits !)

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
Option Explicit
Private Sub Command1_Click()
 Dim choses
 choses = Array("pommes", "poires", "pêches", "abricots", "cerises", "bananes", "fraises", "mangues", "litchis", "kakis", "figues")
 Dim nb As Integer, i As Integer, debut As Integer, fin As Integer, j As Integer, aa As String, bb As String, ps As Integer
 reslst.Clear
 reslst.Visible = False
 nb = UBound(choses) + 1
 For i = 1 To nb
     reslst.AddItem i
 Next
 debut = 0
 fin = reslst.ListCount - 1
 Do
   For i = debut To fin '- 1
     aa = Val(reslst.List(i))
     If aa = 0 Then Exit Do
     bb = reslst.List(i)
     ps = InStr(bb, "-")
     If ps Then
       reslst.List(i) = choses(Val(bb) - 1) & Mid(bb, ps)
     Else
       reslst.List(i) = choses(Val(bb) - 1)
     End If
     For j = aa + 1 To nb
       reslst.AddItem j & "-" & reslst.List(i)
     Next
   Next
   debut = fin + 1
   fin = reslst.ListCount
 Loop
 reslst.Visible = True
 MsgBox reslst.ListCount & " cocktails"
End Sub

Voilà ... C'est propre, efficace et beaucoup plus rapide
Une petire précision : la propriété Sorted de la listbox doit rester à False.
Si vous voulez un résultat trié, c'est l'Array Choses, qu'il faut trier, pas la listbox.