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
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
| Option Explicit
Sub aleatoire()
Dim oPlage_soc As Range, oPlage_dev As Range, oPlage_sec As Range
Dim oRecherche() 'As String
Dim oStr_dev As String, oStr_sec As String, nb_fois As Integer
Dim oRng As Range
Dim i As Integer
Dim oCell As Range
Dim oTitre As Range
With Worksheets("Résultats")
'Titre des résultats
Set oTitre = .Range("A9")
If .Cells(Rows.Count, 3).End(xlUp).Row > oTitre.Row Then
Range(oTitre.Offset(1, 0), .Cells(Rows.Count, 3).End(xlUp)).ClearContents
End If
If .Cells(Rows.Count, 8).End(xlUp).Row > oTitre.Row Then
Range(.Range("F9").Offset(1, 0), .Cells(Rows.Count, 8).End(xlUp)).ClearContents
End If
.Range("B4:F4").ClearContents
.Range("B7:F7").ClearContents
'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("B6:F6")
If oVerif_contenu(oPlage_soc, oPlage_dev, oPlage_sec) Then
oRecherche() = repartition(oPlage_soc, oPlage_dev, oPlage_sec)
Call presente_repart(oRecherche, oPlage_dev, oPlage_sec)
If oRecherche(1, 1) <> "" Then
For i = LBound(oRecherche, 2) To UBound(oRecherche, 2)
oStr_dev = oRecherche(1, i)
oStr_sec = oRecherche(2, i)
nb_fois = oRecherche(3, i)
Set oRng = oRecherche_aleatoire(oStr_dev, oStr_sec, nb_fois)
If Not oRng Is Nothing Then
For Each oCell In oRng
With .Cells(Rows.Count, 1).End(xlUp)
.Offset(1, 0) = oCell
.Offset(1, 1) = oCell.Offset(0, 1)
.Offset(1, 2) = oCell.Offset(0, 2)
End With
Next oCell
End If
Next i
End If
End If
End With
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) Or Not oVerif_pourc(oPlage_dev) Then
oVerif_contenu = False
Exit Function
End If
If Not oVerif(oPlage_sec) Or 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
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, j As Integer
Dim oBool As Boolean
oCount = 1
ReDim oList(1 To 3, 1 To oCount)
oTable_dev = repartition_table(oPlage_soc, oPlage_dev)
oTable_sec = repartition_table(oPlage_soc, oPlage_sec)
If Not oTable_dev(1) = "" Or oTable_sec(1) = "" Then
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
oBool = True
For j = LBound(oList, 2) To UBound(oList, 2)
If oList(1, j) = oPlage_dev.Cells(i).Offset(-1, 0) And oList(2, j) = oPlage_sec.Cells(oVar).Offset(-1, 0) Then
oList(3, j) = oList(3, j) + 1
oBool = False
End If
Next j
If oBool Then
ReDim Preserve oList(1 To 3, 1 To oCount)
oList(1, oCount) = oPlage_dev.Cells(i).Offset(-1, 0)
oList(2, oCount) = oPlage_sec.Cells(oVar).Offset(-1, 0)
oList(3, oCount) = 1
oCount = oCount + 1
End If
oTable_dev(i) = oTable_dev(i) - 1
oTable_sec(oVar) = oTable_sec(oVar) - 1
End If
Loop
Next i
End If
repartition = oList
End Function
Function repartition_table(nb_soc As Range, oPlage_repart As Range)
Dim oTable()
Dim i As Integer, j As Integer
Dim oProp()
Dim oStr As String
Dim oCell As Range
ReDim oTable(1 To oPlage_repart.Cells.Count)
For i = LBound(oTable) To UBound(oTable)
If nb_soc * oPlage_repart.Cells(i) / 100 = Fix(nb_soc * oPlage_repart.Cells(i) / 100) Then
oTable(i) = nb_soc * oPlage_repart.Cells(i) / 100
Else
ReDim oTable(1 To oPlage_repart.Cells.Count)
'MsgBox "Les valeurs sont incohérentes." & vbCrLf & "Veuillez ressaisir les données.", vbCritical, "Valeurs incohérentes"
oProp() = proposition(nb_soc, oPlage_repart)
If oProp(1) <> "" Then
oStr = oProp(1) & "%"
For j = LBound(oProp) + 1 To UBound(oProp)
oStr = oStr & " - " & oProp(j) & "%"
Next j
If MsgBox("Les valeurs sont incohérentes." & vbCrLf & "Voulez-vous essayer celles-ci : " & oStr & " ?", vbYesNo + vbQuestion + vbDefaultButton1, "Valeur incohérente") = vbYes Then
j = 0
For Each oCell In oPlage_repart
j = j + 1
oCell = oProp(j)
Next oCell
repartition_table = repartition_table(nb_soc, oPlage_repart)
Exit Function
End If
Else
MsgBox "Les valeurs sont incohérentes." & vbCrLf & "Pas de proposition trouvée... Veuillez ressaisir les données.", vbCritical, "Valeurs incohérentes"
End If
repartition_table = oTable
Exit Function
End If
Next i
repartition_table = oTable
End Function
Function oRecherche_aleatoire(oDev As String, oSec As String, nb_fois As Integer) As Range
Dim oCell As Range
Dim oRech As Range
Dim oRetour() As Range
Dim oDim As Integer
Dim oVar As Integer
Dim k As Integer
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
Set oRech = Nothing
If nb_fois <= oDim Then
ReDim oResult(1 To nb_fois)
Do While nb_fois > 0
Randomize
oVar = Int((UBound(oRetour) - LBound(oRetour) + 1) * Rnd + LBound(oRetour))
If oRech Is Nothing Then
Set oRech = oRetour(oVar)
nb_fois = nb_fois - 1
Else
If Application.Intersect(oRech, oRetour(oVar)) Is Nothing Then
Set oRech = Union(oRech, oRetour(oVar))
nb_fois = nb_fois - 1
End If
End If
Loop
Else
MsgBox "Pas assez de couples de valeurs suivants dans la BDD : {" & oDev & ", " & oSec & "}.", vbInformation
With Worksheets("Résultats").Cells(Rows.Count, 6).End(xlUp)
.Offset(1, 0) = "Couple : " & oDev & ", " & oSec
.Offset(1, 1) = "En base : " & oDim
.Offset(1, 2) = "Demandé : " & nb_fois
End With
End If
Set oRecherche_aleatoire = oRech
End Function
Function proposition(nb_soc As Range, oPlage_repart As Range)
Dim oPos() ' As Integer
Dim oCell As Range
Dim oCount As Integer, oCount2 As Integer
Dim oMax As Integer
Dim i As Integer
Dim oBool As Boolean
Dim oLimit As Integer
Dim oExit As Boolean
Dim j As Integer, oStr As String
oCount = 0: oCount2 = 0
oMax = 1
oBool = True
ReDim oPos(1 To oPlage_repart.Cells.Count)
For Each oCell In oPlage_repart
oCount2 = oCount2 + 1
If oCell > 0 Then
oCount = oCount + 1
End If
oPos(oCount2) = oCell
If oPos(oMax) < oCell Then
oMax = oCount
End If
Next oCell
oLimit = Int(oPos(oMax) * 1.5)
oExit = False
Do While oBool
oBool = False
oPos(oMax) = oPos(oMax) + oCount - 1
If Not nb_soc * oPos(oMax) / 100 = Fix(nb_soc * oPos(oMax) / 100) Then
oBool = True
End If
For i = LBound(oPos) To UBound(oPos)
If i <> oMax And oPos(i) <> 0 Then
oPos(i) = oPos(i) - 1
If oPos(i) < 0 Then
oExit = True
End If
If Not nb_soc * oPos(i) / 100 = Fix(nb_soc * oPos(i) / 100) Then
oBool = True
End If
End If
Next i
If (Not oBool And oLimit < oPos(oMax)) Or oExit Then
oBool = False
ReDim oPos(1 To 1)
End If
Loop
proposition = oPos
End Function
Sub presente_repart(ma_table(), oPlage_dev As Range, oPlage_sec As Range)
Dim oCell As Range
Dim oCount As Integer
Dim i As Integer
For Each oCell In oPlage_dev
oCount = 0
For i = LBound(ma_table, 2) To UBound(ma_table, 2)
If ma_table(1, i) = oCell.Offset(-1, 0) Then
oCount = oCount + ma_table(3, i)
End If
Next i
oCell.Offset(1, 0) = oCount
Next oCell
For Each oCell In oPlage_sec
oCount = 0
For i = LBound(ma_table, 2) To UBound(ma_table, 2)
If ma_table(2, i) = oCell.Offset(-1, 0) Then
oCount = oCount + ma_table(3, i)
End If
Next i
oCell.Offset(1, 0) = oCount
Next oCell
End Sub
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 |
