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
| Option Explicit
Sub RemplirPlanning()
Dim AgentsDispos() As Integer, AgentsAffectes() As Integer, AgentsAffectesPourCompetence() As Integer
Dim TirageCompetences As Variant
Dim PlageTirage() As Variant
Dim AgentsDisposVide As Boolean, AgentsAffectesVide As Boolean, AgentsAffectesPourCompetenceVide As Boolean
Dim Agent As Range
Dim MaxAgents As Byte, MaxCompetences As Byte
Dim CptAgentsAffectes As Integer, TirageChoixAgent As Integer, CptPlageTirage As Integer, CptAffectation As Integer, CptJours As Integer
Dim CptCompetences As Byte
Dim Tirage As String
Application.ScreenUpdating = False
MaxAgents = 4
MaxCompetences = 7
PlageTirage = Array(9, 25, 42, 60)
Sheets("Mois en cours").Range("F4:L34").ClearContents
Randomize
With Sheets("Compétences")
For CptJours = 4 To 34
If Sheets("Mois en cours").Cells(CptJours, 5).Interior.ColorIndex <> 6 Then
ReDim AgentsAffectes(1 To 1)
AgentsAffectesVide = True
AgentsDisposVide = True
Set TirageCompetences = TirageAleatoireCompetences(MaxCompetences)
For CptCompetences = 1 To MaxCompetences
AgentsAffectesPourCompetenceVide = True
For CptPlageTirage = 0 To UBound(PlageTirage) - 1
AgentsDisposVide = True
For Each Agent In .Range("A" & PlageTirage(CptPlageTirage) & ":A" & PlageTirage(CptPlageTirage + 1) - 1)
If Agent.Offset(, TirageCompetences(CptCompetences) + 1).Value = 1 And Agent.Offset(, TirageCompetences(CptCompetences) + 1).Interior.ColorIndex <> 3 Then
If Not DejaAffecte(Agent.Row, AgentsAffectes) Then
If AgentsDisposVide Then
ReDim AgentsDispos(1 To 1)
AgentsDisposVide = False
Else
ReDim Preserve AgentsDispos(1 To UBound(AgentsDispos) + 1)
End If
AgentsDispos(UBound(AgentsDispos)) = Agent.Row
End If
End If
Next Agent
If Not AgentsDisposVide Then
If UBound(AgentsDispos) > MaxAgents Then
CptAgentsAffectes = 0
While CptAgentsAffectes < MaxAgents
TirageChoixAgent = Int(UBound(AgentsDispos) * Rnd + 1)
If Not DejaAffecte(AgentsDispos(TirageChoixAgent), AgentsAffectes) Then
If AgentsAffectesPourCompetenceVide Then
ReDim AgentsAffectesPourCompetence(1 To 1)
AgentsAffectesPourCompetenceVide = False
Else
ReDim Preserve AgentsAffectesPourCompetence(1 To UBound(AgentsAffectesPourCompetence) + 1)
End If
If AgentsAffectesVide Then
ReDim AgentsAffectes(1 To 1)
AgentsAffectesVide = False
Else
ReDim Preserve AgentsAffectes(1 To UBound(AgentsAffectes) + 1)
End If
AgentsAffectes(UBound(AgentsAffectes)) = AgentsDispos(TirageChoixAgent)
AgentsAffectesPourCompetence(UBound(AgentsAffectesPourCompetence)) = AgentsDispos(TirageChoixAgent)
CptAgentsAffectes = CptAgentsAffectes + 1
End If
Wend
Else
For CptAgentsAffectes = 1 To UBound(AgentsDispos)
If Not DejaAffecte(AgentsDispos(CptAgentsAffectes), AgentsAffectes) Then
If AgentsAffectesPourCompetenceVide Then
ReDim AgentsAffectesPourCompetence(1 To 1)
AgentsAffectesPourCompetenceVide = False
Else
ReDim Preserve AgentsAffectesPourCompetence(1 To UBound(AgentsAffectesPourCompetence) + 1)
End If
If AgentsAffectesVide Then
ReDim AgentsAffectes(1 To 1)
AgentsAffectesVide = False
Else
ReDim Preserve AgentsAffectes(1 To UBound(AgentsAffectes) + 1)
End If
AgentsAffectes(UBound(AgentsAffectes)) = AgentsDispos(CptAgentsAffectes)
AgentsAffectesPourCompetence(UBound(AgentsAffectesPourCompetence)) = AgentsDispos(CptAgentsAffectes)
End If
Next CptAgentsAffectes
End If
End If
Next CptPlageTirage
If Not AgentsAffectesPourCompetenceVide Then
Tirage = ""
For CptAffectation = 1 To UBound(AgentsAffectesPourCompetence)
Tirage = Tirage & .Cells(AgentsAffectesPourCompetence(CptAffectation), 2) & "/"
Next CptAffectation
Sheets("Mois en cours").Cells(CptJours, TirageCompetences(CptCompetences) + 5).Value = Tirage
End If
Next CptCompetences
End If
Next CptJours
End With
Application.ScreenUpdating = True
End Sub
Function DejaAffecte(Agent As Integer, AgentsAffectes() As Integer) As Boolean
Dim Cpt As Integer
For Cpt = 1 To UBound(AgentsAffectes)
If AgentsAffectes(Cpt) = Agent Then
DejaAffecte = True
Exit For
End If
Next
End Function
Function TirageAleatoireCompetences(NbrCompetences As Byte) As Variant
Dim Tablo1 As New Collection, Tablo2 As New Collection
Dim Cpt As Byte
For Cpt = 1 To NbrCompetences
Tablo1.Add Cpt, CStr(Cpt)
Next
Randomize
While Tablo1.Count > 0
Cpt = Int(Tablo1.Count * Rnd + 1)
Tablo2.Add Tablo1(Cpt), CStr(Tablo1(Cpt))
Tablo1.Remove Cpt
Wend
Set TirageAleatoireCompetences = Tablo2
End Function |
