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
| Option Explicit
' Convertir une Collection en tableau de chaînes
Function CollectionToArray(col As Collection) As String()
Dim arr() As String
Dim i As Long
ReDim arr(0 To col.Count - 1)
For i = 1 To col.Count
arr(i - 1) = CStr(col(i))
Next i
CollectionToArray = arr
End Function
' Mélanger un tableau de chaînes
Function ShuffleArray(arr() As String) As String()
Dim i As Long, j As Long
Dim temp As String
Randomize
For i = UBound(arr) To LBound(arr) + 1 Step -1
j = Int((i - LBound(arr) + 1) * Rnd) + LBound(arr)
temp = arr(i)
arr(i) = arr(j)
arr(j) = temp
Next i
ShuffleArray = arr
End Function
' Joindre les éléments d'une Collection
Function JoinCollection(col As Collection, delimiter As String) As String
Dim item As Variant
Dim result As String
result = ""
For Each item In col
result = result & item & delimiter
Next
If Len(result) >= Len(delimiter) Then
result = Left(result, Len(result) - Len(delimiter))
End If
JoinCollection = result
End Function
' Vérifier si tous les collaborateurs sont affectés
Function AllAffectes(collabsDict As Object) As Boolean
Dim key As Variant
For Each key In collabsDict.Keys
If collabsDict(key) = False Then
AllAffectes = False
Exit Function
End If
Next
AllAffectes = True
End Function
' Tri rapide d'un tableau de dates
Sub QuickSortDates(arr() As Variant, ByVal first As Long, ByVal last As Long)
Dim low As Long, high As Long
Dim mid As Variant, temp As Variant
low = first
high = last
mid = arr((first + last) \ 2)
Do While low <= high
Do While arr(low) < mid
low = low + 1
Loop
Do While arr(high) > mid
high = high - 1
Loop
If low <= high Then
temp = arr(low)
arr(low) = arr(high)
arr(high) = temp
low = low + 1
high = high - 1
End If
Loop
If first < high Then Call QuickSortDates(arr, first, high)
If low < last Then Call QuickSortDates(arr, low, last)
End Sub
Sub CreerAffectations()
Dim wsPlanning As Worksheet, wsRepart As Worksheet, wsAbs As Worksheet, wsAffectation As Worksheet, wsDateAnalyse As Worksheet
Dim dictCollaborateurs As Object
Dim absDict As Object
Dim dateAnalyseDict As Object
Dim lastRowAbs As Long, lastRowRepart As Long, lastRowDateAnalyse As Long, lastRowPlanning As Long
Dim i As Long, iRow As Long
Dim dateVal As Date
Dim jour As String
Dim allCollaboratorsDict As Object ' Variable renommée pour éviter conflit
Dim dates As Variant
Dim dateMinProchainOTO As Date
Dim dateArr() As Variant
Dim d As Variant ' Déclaration ici pour éviter conflit
Dim collab As Variant
Dim superv As String
Dim dateCourante As Date ' Variable pour la date courante
Dim ligneAffect As Long
Application.ScreenUpdating = False
' Définir les feuilles
Set wsPlanning = ThisWorkbook.Worksheets("Planning sup OTO")
Set wsRepart = ThisWorkbook.Worksheets("répart effectif")
Set wsAbs = ThisWorkbook.Worksheets("Planning abs")
Set wsDateAnalyse = ThisWorkbook.Worksheets("Date analyse contrat")
' Créer ou nettoyer la feuille "Affectation"
On Error Resume Next
Set wsAffectation = ThisWorkbook.Worksheets("Affectation")
If wsAffectation Is Nothing Then
Set wsAffectation = ThisWorkbook.Worksheets.Add
wsAffectation.Name = "Affectation"
Else
wsAffectation.Cells.Clear
End If
On Error GoTo 0
' En-têtes
wsAffectation.Range("A1").Value = "Date"
wsAffectation.Range("B1").Value = "Groupe"
wsAffectation.Range("C1").Value = "Collaborateurs"
ligneAffect = 2
' Récupérer tous les collaborateurs avec leur superviseur
Set dictCollaborateurs = CreateObject("Scripting.Dictionary")
lastRowRepart = wsRepart.Cells(wsRepart.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRowRepart
Dim nomCollab As String
nomCollab = wsRepart.Cells(i, 1).Value
superv = wsRepart.Cells(i, 2).Value
dictCollaborateurs(nomCollab) = superv
Next i
' Récupérer les absences dans un dictionnaire
Set absDict = CreateObject("Scripting.Dictionary")
lastRowAbs = wsAbs.Cells(wsAbs.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRowAbs
collab = wsAbs.Cells(i, 1).Value
If IsDate(wsAbs.Cells(i, 2).Value) Then
dateVal = CDate(wsAbs.Cells(i, 2).Value)
If Not absDict.exists(collab) Then
Set absDict(collab) = New Collection
End If
absDict(collab).Add dateVal
End If
Next i
' Récupérer la "Date minimum du prochain OTO" dans "Date analyse contrat"
Set dateAnalyseDict = CreateObject("Scripting.Dictionary")
lastRowDateAnalyse = wsDateAnalyse.Cells(wsDateAnalyse.Rows.Count, 1).End(xlUp).Row
For i = 2 To lastRowDateAnalyse
If IsDate(wsDateAnalyse.Cells(i, 1).Value) Then
Dim dateProchain As Date
dateProchain = wsDateAnalyse.Cells(i, 6).Value
If Not dateAnalyseDict.exists("min") Then
dateAnalyseDict("min") = dateProchain
Else
If dateProchain < dateAnalyseDict("min") Then
dateAnalyseDict("min") = dateProchain
End If
End If
End If
Next i
If dateAnalyseDict.exists("min") Then
dateMinProchainOTO = dateAnalyseDict("min")
Else
' Si aucune date trouvée
dateMinProchainOTO = DateSerial(2000, 1, 1)
End If
' Récupérer toutes les dates dans "Planning sup OTO" où colonne 2 n’est pas vide
lastRowPlanning = wsPlanning.Cells(wsPlanning.Rows.Count, 1).End(xlUp).Row
Dim dateFilterDict As Object
Set dateFilterDict = CreateObject("Scripting.Dictionary")
For iRow = 2 To lastRowPlanning
If Not IsEmpty(wsPlanning.Cells(iRow, 2).Value) And IsDate(wsPlanning.Cells(iRow, 1).Value) Then
Dim dt As Date
dt = CDate(wsPlanning.Cells(iRow, 1).Value)
dateFilterDict(dt) = True
End If
Next iRow
' Liste de toutes les dates dans "Date analyse contrat" pour répartir
Dim dateList As New Collection
For i = 2 To lastRowDateAnalyse
If IsDate(wsDateAnalyse.Cells(i, 6).Value) Then
Dim dateDansAnalyse As Date
dateDansAnalyse = CDate(wsDateAnalyse.Cells(i, 6).Value)
' On ne garde que les dates après la date du prochain OTO
If dateDansAnalyse >= dateMinProchainOTO Then
Dim exists As Boolean
exists = False
Dim dateValItem As Variant
For Each dateValItem In dateList
If CDate(dateValItem) = dateDansAnalyse Then
exists = True
Exit For
End If
Next
If Not exists Then
dateList.Add dateDansAnalyse
End If
End If
End If
Next
' Si aucune date
If dateList.Count = 0 Then
MsgBox "Aucune date disponible pour l'affectation après la date du prochain OTO."
Application.ScreenUpdating = True
Exit Sub
End If
' Trier les dates
ReDim dateArr(0 To dateList.Count - 1)
For i = 1 To dateList.Count
dateArr(i - 1) = dateList(i)
Next i
Call QuickSortDates(dateArr, LBound(dateArr), UBound(dateArr))
' Liste de tous les collaborateurs
Dim allCollaborators As Object
Set allCollaborators = CreateObject("Scripting.Dictionary")
Dim key As Variant
For Each key In dictCollaborateurs.Keys
allCollaborators(key) = False ' Pas encore affectés
Next
' Préparer le dictionnaire pour suivre l'affectation
Dim collaborateursAffectes As Object
Set collaborateursAffectes = CreateObject("Scripting.Dictionary")
For Each key In allCollaborators.Keys
collaborateursAffectes(key) = False
Next
' Boucle sur chaque date
For Each d In dateArr
' La date dans "Planning sup OTO"
Dim dateDebutContrat As Date
Dim trouveDate As Boolean
trouveDate = False
' Chercher la date dans "Planning sup OTO"
For iRow = 2 To lastRowPlanning
If Not IsEmpty(wsPlanning.Cells(iRow, 2).Value) And IsDate(wsPlanning.Cells(iRow, 1).Value) Then
Dim planningDate As Date
planningDate = CDate(wsPlanning.Cells(iRow, 1).Value)
If planningDate = d Then
dateDebutContrat = planningDate
trouveDate = True
Exit For
End If
End If
Next iRow
If trouveDate Then
' La variable 'dateCourante' prend cette valeur
dateCourante = dateDebutContrat
' Vérifier que cette date est > colonne 6 de "Date analyse contrat"
Dim dateCol6 As Date
dateCol6 = dateMinProchainOTO
If dateDebutContrat > dateCol6 Then
' Affectation : Vérifier absences
Dim dispoList As New Collection
For Each collab In allCollaborators.Keys
Dim absentCeJour As Boolean
absentCeJour = False
If absDict.exists(collab) Then
Dim absences As Collection
Set absences = absDict(collab)
Dim absDate As Variant
For Each absDate In absences
If absDate = dateCourante Then
absentCeJour = True
Exit For
End If
Next
End If
If Not absentCeJour Then
dispoList.Add collab
End If
Next
' Mélanger et prendre jusqu'à 5
Dim dispoArray() As String
dispoArray = CollectionToArray(dispoList)
dispoArray = ShuffleArray(dispoArray)
Dim nbAffectes As Long
nbAffectes = Application.WorksheetFunction.Min(5, UBound(dispoArray) - LBound(dispoArray) + 1)
If nbAffectes > 0 Then
Dim groupe As New Collection
Dim j As Long
For j = 0 To nbAffectes - 1
collab = dispoArray(j)
groupe.Add collab
collaborateursAffectes(collab) = True
Next j
' Enregistrement
wsAffectation.Cells(ligneAffect, 1).Value = dateCourante
wsAffectation.Cells(ligneAffect, 2).Value = "Groupe " & d ' ou autre identifiant
wsAffectation.Cells(ligneAffect, 3).Value = JoinCollection(groupe, ", ")
ligneAffect = ligneAffect + 1
End If
End If
End If
Next d
Application.ScreenUpdating = True
MsgBox "Affectations créées avec succès!"
End Sub |
Macro VBA - rotation par groupe de 5 selon des dates de disponibilité
Répondre avec citation
Partager