Discussion :

[Emmasam]

Bonjour ,
J aurais besoin de votre aide car je n arrive pas à obtenir le bon résultat à cette macro .En résumé voici le résultat que je souhaite : je souhaite avoir dans la feuille "Affectation" des groupes de 5 personnes sur les dates de disponibilités .En respectant les critères suivants :
- les des collaborateurs à affecter disponible dans la feuille "Date analyse contrat " , colonne A "Nom Prénom pour exploitation "
- date de début des affectations possible présente dans la feuille "Date analyse contrat " , colonne F "Date minimum du prochain OTO "
- passer l intégralité des collaborateurs en affectation avant d entamer un nouveau cycle
- avoir un délai minimum de 30 jours entre chaque affectation
- liste des dates disponibles présentes dans la feuille "Planning sup OTO" colonne b non vide
- vérifier que le collaborateur n est pas absent le jour de son affectation , sinon l affecter à une autre date : planning des absences dispo dans la feuille "Planning abs" (1ere colonne nom - 2eme colonne date)
- l affectation du collaborateur ne doit pas être faite avec son supérieur habituel : supérieur habituel présent dans la feuille "Repart effectif" (colonne 1 "collaborateur" , colonne 2 "sup") qui ne doit pas être celui retrouvé à la date choisi dans la colonne 2 de la feuille "Planning sup OTO"
- le résultat doit être sous le format date / sup réalisation l oto à cette date / groupe de 5 max (nom séparé par une virgule)

Le code que j avais et qui serais à corriger est le suivant :

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
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

En vous remerciant de votre aide car cela fait plus de 15 jours que j essaye de corriger sans y arriver

[rMist2024]

Sans fichier exemple ça sera très difficile pour avoir d'idée sur la structure des données et sur le résultat attendu

[mach1974]

de ce que je vois du code
wsPlanning.Cells(wsPlanning.Rows.Count, 1).End(xlUp).Row n'est pas correcte ou il faut plutôt remplacer par wsPlanning.End(xlUp).Row . après les End(Xlup) s'arrête à la premier ligne rencontrée. Il faut voir si dans les feuilles sources, il n'y pas pas une ligne blanche entre deux dates .
Il pourrait être intéressant de mettre sur la feuille source un autofilter.sort avec un tri et la valeur de la ligne blanche est la plus petite

[tototiti2008]

Bonjour,

J'ignore si vous nous prenez pour des magiciens mais déboguer 300 lignes de code sans disposer des données sur lesquelles elles s'appliquent ni même voir comment elles sont structurées, c'est un peu comme demander de résoudre un rubix cube les yeux bandés.
y a peut-être des personnes qui se sont spécifiquement entrainées à ce tour de magie mais ce n'est pas le plus courant