Discussion :

[enivral]

Bonjour le forum,

Après m'avoir aidé maintes fois en tant qu'utilisateur sous marin, je me suis décidé à poster ma question ne trouvant pas spécialement de réponses ailleurs.

J'essaie de créer un fichier afin de randomiser la sélection de lignes pour un portefeuille boursier.

J'ai donc une base de données qui se présente comme suit : (si besoin, la disposition des données peut être entièrement revu)

Colonne A : nom de la société
Colonne B : secteur d'activité
Colonne C : devise

Par exemple

Société 1 | santé | eur
Société 2 | banque | usd
Société 3 | santé | usd
Société 4 | industrie | chf
Société 5 | santé | eur
Société 6 | santé | usd

J'aimerais arriver à sortir de manière aléatoire une liste de sociétés répondant à divers critères :

nb de société voulu (ex: 2)
la répartition en devises (ex 50% usd et 50% eur)
la répartition en secteur (ex: 100% santé)

Je précise que j'ai 10 secteurs, environ 130 sociétés, 5 devises.

Ainsi, en respectant ces critères, excel devrait me sortir en résultats :

- Société 1 et 3
ou
- Société 1 et 6
ou
- Société 5 et 3
ou
-Société 5 et 6

Evidemment pour 2 lignes sur 6 c'est plus facile que pour 20 sur 130

Je ne sais pas du tout par ou commencer, j'ai regardé du côté des sélections aléatoires mais apparemment la sélection aléatoire "assistée" de critère n'est pas abordée.

Je suis sur Excel 2010, version anglaise.

En espérant avoir été clair, sinon n’hésitez pas à me demander des précisions.
D'avance merci pour vos réponses

Enivral

[Kimy_Ire]

Bonjour enivral,

J'aime bien ton problème !
En revanche, en établissant une macro qui pourrait répondre à ton besoin, je me suis aperçu d'une difficulté.

Souhaites-tu pouvoir définir une répartition de devises ET de secteurs comme ceci par exemple :

• Nb sociétés : 4
• Répartition devise : eur = 50%, usd = 0%, chf = 50%
• Répartition secteur : santé = 25%, banque = 25%, secteur = 25%, industrie = 25%

Si tel est le cas, le nombre de combinaisons possibles dans ce cas est plutôt important !

On pourrait avoir :

• Soc1 = eur + santé, Soc2 = eur + banque, Soc3 = chf + secteur, Soc4 = chf + industrie

OU

• Soc1 = eur + banque, Soc2 = eur + secteur, Soc3 = chf + industrie, Soc4 = chf + santé

OU

• Soc1 = eur + secteur, Soc2 = eur + industrie, Soc3 = chf + santé, Soc4 = chf + banque

OU
etc...
Et encore, ce cas là est simple. Si on le complexifie on tombe rapidement sur un nombre de combinaison relativement important.

Donc ma question : as-tu des limitations fonctionnelles qui permettent de simplifier le nombre de combinaison que tu souhaites ?
J'attends ton retour !

Cordialement,
Kimy

[enivral]

Bonjour Kimy,

Ravi que mon problème te plaise

Effectivement tu soulève un bon point.
Dans l'idéal, oui je voudrais que la répartition devises et secteur soit couplées ceci afin de respecter les principes de diversification sectorielle et en devise ^^

Pense-tu que ça puisse le faire ou cela va se transformer en usine à gaz ?

Il est peut être plus simple de traiter d'abord la répartition en secteur puis de tester la répartition en devise ? .... et de recommencer si ça match pas.... mais en fessant ça je sens bien la boucle bien lourde à exécuter

Si cela peut t'aider l'idée viens d'ici (mais datant de 2010 et codée en javascript )
http://www.devenir-rentier.fr/blog/rentier/article/202/
(en espérant que j'ai le droit d’insérer des liens)

[Kimy_Ire]

Re,

J'ai quasiment fini.
J'ai même trouvé un moyen de gérer la difficulté présentée avant.

En revanche, autre point :

• Nb sociétés : 5
• Répartition devise : eur = 50%, usd = 0%, chf = 50%
• Répartition secteur : santé = 25%, banque = 25%, secteur = 25%, industrie = 25%

Qu'est-ce qu'il faut faire dans ce cas ?

Cordialement,
Kimy

[Kimy_Ire]

Bon, premier jet :

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
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
Option Explicit
 
Sub aleatoire()
Dim oPlage_soc As Range, oPlage_dev As Range, oPlage_sec As Range
Dim oRecherche() 'As String
Dim oFiltre()
Dim oStr_dev As String, oStr_sec As String
Dim oRng As Range
Dim i As Integer
 
With Worksheets("Résultats")
    'Plage du nombre des sociétés
    Set oPlage_soc = .Range("B1")
    'Plage des répartitions des devises
    Set oPlage_dev = .Range("B3:D3")
    'Plage des répartitions des secteurs
    Set oPlage_sec = .Range("B5:F5")
 
    If oVerif_contenu(oPlage_soc, oPlage_dev, oPlage_sec) Then
        oRecherche() = repartition(oPlage_soc, oPlage_dev, oPlage_sec)
 
        For i = LBound(oRecherche, 1) To UBound(oRecherche, 1)
            oStr_dev = oRecherche(i, LBound(oRecherche, 2))
            oStr_sec = oRecherche(i, UBound(oRecherche, 2))
            Set oRng = oRecherche_aleatoire(oStr_dev, oStr_sec)
 
            With .Range("A8")
                .Offset(i, 0) = oRng
                .Offset(i, 1) = oRng.Offset(0, 1)
                .Offset(i, 2) = oRng.Offset(0, 2)
            End With
        Next i
    End If
End With
 
'oStr = ""
'For i = LBound(oRecherche, 1) To UBound(oRecherche, 1)
'    For j = LBound(oRecherche, 2) To UBound(oRecherche, 2)
'        'oStr = oStr & " - " & oRecherche(i, j)
'        'oRecherche_aleatoire(oRecherche(i, j)
'    Next j
'    'oStr = oStr & vbCrLf
'Next i
''MsgBox oStr
 
 
End Sub
 
Function oVerif_contenu(oPlage_soc As Range, oPlage_dev As Range, oPlage_sec As Range) As Boolean
 
'Vérifications
If oVerif(oPlage_soc) Then
    If Not oVerif(oPlage_dev) And Not oVerif_pourc(oPlage_dev) Then
        oVerif_contenu = False
        Exit Function
    End If
 
    If Not oVerif(oPlage_sec) And Not oVerif_pourc(oPlage_sec) Then
        oVerif_contenu = False
        Exit Function
    End If
Else
    oVerif_contenu = False
    Exit Function
End If
 
oVerif_contenu = True
 
End Function
 
Function oVerif(oRng As Range) As Boolean ' Optional oTest As Boolean = False) As Boolean
Dim oCell As Range
 
For Each oCell In oRng
    With oCell
        If IsNumeric(.Value) Then
            If .Value = Fix(.Value) Then
                If Not .Value >= 0 Then
                    MsgBox "La valeur en " & .Address & " doit être suppérieure ou égale à 0.", vbCritical
                    oVerif = False
                    Exit Function
                End If
            Else
                MsgBox "La valeur en " & .Address & " doit être entier.", vbCritical
                oVerif = False
                Exit Function
            End If
        Else
            MsgBox "La valeur en " & .Address & " doit être numérique.", vbCritical
            oVerif = False
            Exit Function
        End If
    End With
Next oCell
 
oVerif = True
 
End Function
 
Function oVerif_pourc(oRng As Range) As Boolean
Dim oCell As Range
Dim oPourc As Integer
 
oPourc = 0
With oRng
    For Each oCell In oRng
        oPourc = oPourc + oCell
    Next oCell
End With
 
If oPourc = 100 Then
    oVerif_pourc = True
Else
    MsgBox "La somme des valeurs en " & oRng.Address & " n'est pas égale à 100.", vbCritical
    oVerif_pourc = False
End If
 
End Function
 
Function repartition(oPlage_soc As Range, oPlage_dev As Range, oPlage_sec As Range)
Dim oTable_dev() 'As Integer
Dim oTable_sec() 'As Integer
Dim oList()
Dim oVar As Integer
Dim oCount As Integer
Dim i As Integer
 
ReDim oList(1 To oPlage_soc, 1 To 2)
oCount = 1
 
oTable_dev = repartition_table(oPlage_soc, oPlage_dev)
oTable_sec = repartition_table(oPlage_soc, oPlage_sec)
 
For i = LBound(oTable_dev) To UBound(oTable_dev)
    Do While oTable_dev(i) <> 0
        Randomize
        oVar = Int((UBound(oTable_sec) - LBound(oTable_sec) + 1) * Rnd + LBound(oTable_sec))
        If oTable_sec(oVar) > 0 Then
            oList(oCount, 1) = oPlage_dev.Cells(i).Offset(-1, 0)
            oList(oCount, 2) = oPlage_sec.Cells(oVar).Offset(-1, 0)
 
            oTable_dev(i) = oTable_dev(i) - 1
            oTable_sec(oVar) = oTable_sec(oVar) - 1
            oCount = oCount + 1
        End If
    Loop
Next i
 
repartition = oList
 
End Function
 
Function repartition_table(nb_soc As Range, oPlage_repart As Range)
Dim oTable()
Dim i As Integer
 
ReDim oTable(1 To oPlage_repart.Cells.Count)
For i = LBound(oTable) To UBound(oTable)
    oTable(i) = CInt(nb_soc * oPlage_repart.Cells(i) / 100)
Next i
 
repartition_table = oTable
 
End Function
 
Function oRecherche_aleatoire(oDev As String, oSec As String) As Range
Dim oCell As Range
Dim oRech As Range
Dim oRetour() As Range
Dim oDim As Integer
Dim oVar As Integer
 
'Dim i
 
oDim = 0
With Worksheets("BDD")
    Set oRech = FindAll(Range(.Range("C1"), .Cells(Rows.Count, 3).End(xlUp)), oDev)
    For Each oCell In oRech
        If oCell.Offset(0, -1) = oSec Then
            oDim = oDim + 1
            ReDim Preserve oRetour(1 To oDim)
            Set oRetour(oDim) = oCell.Offset(0, -2)
        End If
    Next oCell
End With
 
If oDim > 0 Then
    Randomize
    oVar = Int((UBound(oRetour) - LBound(oRetour) + 1) * Rnd + LBound(oRetour))
 
    Set oRecherche_aleatoire = oRetour(oVar)
Else
    MsgBox "Pas de couple de valeur suivant dans la BDD : {" & oDev & ", " & oSec & "}"
End If
 
'MsgBox oDev & " - " & oSec
'For i = LBound(oRetour) To UBound(oRetour)
'    MsgBox oRetour(i).Address
'Next i
 
End Function
 
Function FindAll(SearchRange As Range, _
                FindWhat As Variant, _
               Optional LookIn As XlFindLookIn = xlValues, _
                Optional LookAt As XlLookAt = xlWhole, _
                Optional SearchOrder As XlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean = False, _
                Optional BeginsWith As String = vbNullString, _
                Optional EndsWith As String = vbNullString, _
                Optional BeginEndCompare As VbCompareMethod = vbTextCompare) As Range
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' FindAll
' This searches the range specified by SearchRange and returns a Range object
' that contains all the cells in which FindWhat was found. The search parameters to
' this function have the same meaning and effect as they do with the
' Range.Find method. If the value was not found, the function return Nothing. If
' BeginsWith is not an empty string, only those cells that begin with BeginWith
' are included in the result. If EndsWith is not an empty string, only those cells
' that end with EndsWith are included in the result. Note that if a cell contains
' a single word that matches either BeginsWith or EndsWith, it is included in the
' result.  If BeginsWith or EndsWith is not an empty string, the LookAt parameter
' is automatically changed to xlPart. The tests for BeginsWith and EndsWith may be
' case-sensitive by setting BeginEndCompare to vbBinaryCompare. For case-insensitive
' comparisons, set BeginEndCompare to vbTextCompare. If this parameter is omitted,
' it defaults to vbTextCompare. The comparisons for BeginsWith and EndsWith are
' in an OR relationship. That is, if both BeginsWith and EndsWith are provided,
' a match if found if the text begins with BeginsWith OR the text ends with EndsWith.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
 
Dim FoundCell As Range
Dim FirstFound As Range
Dim LastCell As Range
Dim ResultRange As Range
Dim XLookAt As XlLookAt
Dim Include As Boolean
Dim CompMode As VbCompareMethod
Dim Area As Range
Dim MaxRow As Long
Dim MaxCol As Long
Dim BeginB As Boolean
Dim EndB As Boolean
 
 
CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
    XLookAt = xlPart
Else
    XLookAt = LookAt
End If
 
' this loop in Areas is to find the last cell
' of all the areas. That is, the cell whose row
' and column are greater than or equal to any cell
' in any Area.
 
For Each Area In SearchRange.Areas
    With Area
        If .Cells(.Cells.Count).Row > MaxRow Then
            MaxRow = .Cells(.Cells.Count).Row
        End If
        If .Cells(.Cells.Count).Column > MaxCol Then
            MaxCol = .Cells(.Cells.Count).Column
        End If
    End With
Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)
 
On Error GoTo 0
Set FoundCell = SearchRange.Find(what:=FindWhat, _
        After:=LastCell, _
        LookIn:=LookIn, _
        LookAt:=XLookAt, _
        SearchOrder:=SearchOrder, _
        MatchCase:=MatchCase)
 
If Not FoundCell Is Nothing Then
    Set FirstFound = FoundCell
    Do Until False ' Loop forever. We'll "Exit Do" when necessary.
        Include = False
        If BeginsWith = vbNullString And EndsWith = vbNullString Then
            Include = True
        Else
            If BeginsWith <> vbNullString Then
                If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
            If EndsWith <> vbNullString Then
                If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                    Include = True
                End If
            End If
        End If
        If Include = True Then
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = Application.Union(ResultRange, FoundCell)
            End If
        End If
        Set FoundCell = SearchRange.FindNext(After:=FoundCell)
        If (FoundCell Is Nothing) Then
            Exit Do
        End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
        End If
 
    Loop
End If
 
Set FindAll = ResultRange
 
End Function

La dernière Function utilisée est la fonction FindAll qu'on trouve sur le net.
Je te joint le classeur parce que je n'ai pas le temps tout de suite de mettre les commentaires pour que tu adaptes. => aléatoire.xlsm

Ca te permettra de me dire si ça te convient déjà.
Peut-être que je n'ai pas compris !
Bref, il faut savoir que je n'ai pas encore géré le cas où les % ne tombent pas entier.

A tout à l'heure.

Cordialement,
Kimy

[EDIT] Je n'ai pas gérer, non plus, le cas où tu mets "trop" de valeurs. Je fais ça dans l'aprèm'.

[enivral]

Wahou c'est du rapide

Je regarde tout ça afin de te faire un retour.

Pour le cas ou les % ne tombent pas entier je pense me débrouiller avec par exemple un msgbox prévenant l'utilisateur et / ou lui proposant une répartition proche.

Enfin, le but c'est que je tombe entier à tous les coups

Un grand merci pour le travaille déjà fait.

EDIT: pour le moment les quelques test sont super concluants MERCI
Il faut que je me plonge dans ton code afin de le comprendre un peu plus