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
|
Dim Valeur As String
Dim Nb_Tirage As Integer, Nb_Alea As Integer
Dim i As Long, j As Long, l As Long, c As Long, t As Long, s As Long, Nb_de_C_place As Long, NbVal As Long
Dim Liste As String
Dim Deb As Date
Sub Tirage_aleatoire()
Application.ScreenUpdating = False
'on efface les précédents tirages
For i = 7 To 47 Step 4
Range(Cells(2, i), Cells(55, i)).ClearContents
Next i
'Forçage à C de tous les 20h
For l = 2 To 55
For c = 10 To 50 Step 4
If Cells(l, c) = 20 Then Cells(l, c - 3) = "C"
Next c, l
Nouveau_Tirage:
Randomize 'Initialise le générateur de nombres aléatoires
For s = 2 To 51 Step 7 'pour chaque semaine
For i = s To s + 4 'tirage pour la semaine sélectionné
For j = 1 To 5 'les valeurs à placer
Valeur = Cells(1, j)
If Valeur <> "C" Then
If Cells(1, j) <> 0 Then
Nb_Tirage = Cells(i, j)
Tirage
End If
Else
Nb_de_C_place = Application.WorksheetFunction.CountIf(Range(Cells(i, "G").Address & ":" & Cells(i, "AX").Address), "C")
If Cells(1, j) > Nb_de_C_place Then
Nb_Tirage = Cells(i, j) - Nb_de_C_place
If Nb_Tirage > 0 Then Tirage
End If
End If
Next j
Next i
Next s
End Sub
Sub Tirage()
Echec = False
For t = 1 To Nb_Tirage
Deb = Time
Tirage_aleatoire:
If Time > Deb + 1 / 86400 Then 'si le tirage est impossible au bout d'une seconde, on recommence tout
Tirage_aleatoire
Exit Sub
End If
'Conrôle par ligne, vérification de la présence des horaires
Nb_Alea = (Int(11 * Rnd) + 1) 'Nombre aléatoire entier entre 1 et 11
Set Empl = Rows(1).Find(Nb_Alea, LookIn:=xlValues, lookat:=xlWhole)
If Cells(i, Empl.Column + 3) = 21 And Cells(i, Empl.Column) = "" Then
Cells(i, Empl.Column) = Valeur 'on y affecte la valeur
Else
GoTo Tirage_aleatoire 'sinon on refait un tirage aléatoire
End If
'Contrôle par colonne, à partir du mercredi, vérifie que l'employé n'est pas occupé à faire 2 fois la même tâche
If i > 3 And Cells(i, Empl.Column + 3) = 21 Then
NbLigInter = i - 1
Plage = Cells(s, Empl.Column).Address & ":" & Cells(i - 1, Empl.Column).Address
If Application.WorksheetFunction.CountIf(Range(Plage), Valeur) = 2 Then
Cells(i, Empl.Column) = ""
GoTo Tirage_aleatoire 'sinon on refait un tirage aléatoire
End If
End If
Next t
End Sub |
