Macro VBA - rotation par groupe de 5 selon des dates de disponibilité

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 :

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

Hello,

Essaie ça dans un nouveau module.

En théorie, ça traite les cas qui deconnaient :

- Tous les collaborateurs sont affectés une fois chacun avant de recommencer un nouveau cycle

- Respect des 30 jours minimum entre deux affectations d’un collaborateur

- Prise en compte des absences

- respect dates de dispo

- exclusion des dates où le superviseur habituel est superviseur sur le jour

- groupe de 5 personnes

Et il faut que les données de chaque feuille commencent à la ligne 2

Option Explicit

Sub GenererGroupesAffectation()
    Dim wsAffectation As Worksheet, wsPlanning As Worksheet, wsRepart As Worksheet
    Dim wsAbs As Worksheet, wsAnalyse As Worksheet
    Dim dictSuperviseurs As Object, dictAbsences As Object, dictDerniereAffectation As Object
    Dim dictSuperviseurParDate As Object
    Dim collabs As Collection, datesDispo As Collection
    Dim rng As Range, cell As Range
    Dim i As Long, j As Long
    Dim dateRef As Date
    Dim collab As String, dateDispo As Date, nomSup As String
    Dim affectesDansCycle As Collection
    Dim maxParGroupe As Long: maxParGroupe = 5
    Dim ligneResultat As Long: ligneResultat = 2

    Application.ScreenUpdating = False

    ' Initialisations
    Set wsAffectation = ThisWorkbook.Sheets("Affectation")
    Set wsPlanning = ThisWorkbook.Sheets("Planning sup OTO")
    Set wsRepart = ThisWorkbook.Sheets("répart effectif")
    Set wsAbs = ThisWorkbook.Sheets("Planning abs")
    Set wsAnalyse = ThisWorkbook.Sheets("Date analyse contrat")

    Set dictSuperviseurs = CreateObject("Scripting.Dictionary")
    Set dictAbsences = CreateObject("Scripting.Dictionary")
    Set dictDerniereAffectation = CreateObject("Scripting.Dictionary")
    Set dictSuperviseurParDate = CreateObject("Scripting.Dictionary")
    Set collabs = New Collection
    Set datesDispo = New Collection
    Set affectesDansCycle = New Collection

    ' Nettoyer feuille Affectation
    wsAffectation.Cells.Clear
    wsAffectation.Range("A1:C1").Value = Array("Date", "Superviseur OTO", "Groupe")

    ' Liste des collaborateurs + superviseur habituel
    Dim lastRow As Long: lastRow = wsRepart.Cells(wsRepart.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        If wsRepart.Cells(i, 1).Value <> "" Then
            collab = wsRepart.Cells(i, 1).Value
            nomSup = wsRepart.Cells(i, 2).Value
            dictSuperviseurs(collab) = nomSup
            collabs.Add collab
        End If
    Next i

    ' Absences
    lastRow = wsAbs.Cells(wsAbs.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        collab = wsAbs.Cells(i, 1).Value
        If IsDate(wsAbs.Cells(i, 2).Value) Then
            dateDispo = CDate(wsAbs.Cells(i, 2).Value)
            If Not dictAbsences.exists(collab) Then Set dictAbsences(collab) = CreateObject("Scripting.Dictionary")
            dictAbsences(collab)(dateDispo) = True
        End If
    Next i

    ' Dates valides + superviseurs assignés
    lastRow = wsPlanning.Cells(wsPlanning.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        If IsDate(wsPlanning.Cells(i, 1).Value) And wsPlanning.Cells(i, 2).Value <> "" Then
            dateDispo = CDate(wsPlanning.Cells(i, 1).Value)
            nomSup = wsPlanning.Cells(i, 2).Value
            dictSuperviseurParDate(dateDispo) = nomSup
        End If
    Next i

    ' Date de début = plus petite date de colonne F ("Date minimum du prochain OTO")
    Dim dateMinOTO As Date: dateMinOTO = DateSerial(2100, 1, 1)
    lastRow = wsAnalyse.Cells(wsAnalyse.Rows.Count, 1).End(xlUp).Row
    For i = 2 To lastRow
        If IsDate(wsAnalyse.Cells(i, 6).Value) Then
            If CDate(wsAnalyse.Cells(i, 6).Value) < dateMinOTO Then
                dateMinOTO = CDate(wsAnalyse.Cells(i, 6).Value)
            End If
        End If
    Next i

    ' Extraire toutes les dates disponibles à partir de dateMinOTO
    For Each dateDispo In dictSuperviseurParDate.Keys
        If dateDispo >= dateMinOTO Then
            datesDispo.Add dateDispo
        End If
    Next dateDispo

    ' Trier les dates
    Call TrierCollectionDates(datesDispo)

    ' Boucle principale
    Do While True
        ' Recharger affectés dans le cycle
        Set affectesDansCycle = New Collection

        ' Si tous les collaborateurs ont été affectés, sortir
        Dim tousAffectes As Boolean: tousAffectes = True
        For Each collab In collabs
            If Not dictDerniereAffectation.exists(collab) Then
                tousAffectes = False
                Exit For
            End If
        Next
        If tousAffectes Then Exit Do

        ' Boucle sur les dates
        For Each dateDispo In datesDispo
            If Not dictSuperviseurParDate.exists(dateDispo) Then GoTo prochaineDate
            nomSup = dictSuperviseurParDate(dateDispo)

            Dim groupe As Collection: Set groupe = New Collection

            ' Recherche de collaborateurs à affecter
            For Each collab In collabs
                If groupe.Count >= maxParGroupe Then Exit For
                If ExisteDansCollection(affectesDansCycle, collab) Then GoTo suiteCollab

                ' Absence ?
                If dictAbsences.exists(collab) Then
                    If dictAbsences(collab).exists(dateDispo) Then GoTo suiteCollab
                End If

                ' Supérieur identique ?
                If dictSuperviseurs(collab) = nomSup Then GoTo suiteCollab

                ' 30 jours ?
                If dictDerniereAffectation.exists(collab) Then
                    If DateDiff("d", dictDerniereAffectation(collab), dateDispo) < 30 Then GoTo suiteCollab
                End If

                ' OK => on ajoute
                groupe.Add collab
                affectesDansCycle.Add collab
                dictDerniereAffectation(collab) = dateDispo

suiteCollab:
            Next collab

            ' Si on a un groupe, on l’enregistre
            If groupe.Count > 0 Then
                wsAffectation.Cells(ligneResultat, 1).Value = dateDispo
                wsAffectation.Cells(ligneResultat, 2).Value = nomSup
                wsAffectation.Cells(ligneResultat, 3).Value = JoinCollection(groupe, ", ")
                ligneResultat = ligneResultat + 1
            End If

prochaineDate:
        Next dateDispo
    Loop

    MsgBox "Affectations générées avec succès."
    Application.ScreenUpdating = True
End Sub

Function TrierCollectionDates(col As Collection)
    Dim i As Long, j As Long
    Dim temp As Variant
    For i = 1 To col.Count - 1
        For j = i + 1 To col.Count
            If col(i) > col(j) Then
                temp = col(i)
                col(i) = col(j)
                col(j) = temp
            End If
        Next j
    Next i
End Function

Function ExisteDansCollection(col As Collection, val As Variant) As Boolean
    Dim v As Variant
    For Each v In col
        If v = val Then
            ExisteDansCollection = True
            Exit Function
        End If
    Next
    ExisteDansCollection = False
End Function

Function JoinCollection(col As Collection, delim As String) As String
    Dim s As String, v As Variant
    For Each v In col
        s = s & v & delim
    Next
    If Len(s) > 0 Then s = Left(s, Len(s) - Len(delim))
    JoinCollection = s
End Function

@+

Et voilà, félicitations @Baroute !! Et en 2100 on fait comment ?! Le bug de l'an 2000 ?? Les gens n'ont vraiment aucune aniticipation… Non bravo, ta solution a l'air très bien

Bonjour Baroute 78,

Tout d abord merci pour les corrections .Toutefois il me reste un soucis concernant le résultat, en effet au niveau de l affectation j ai plusieurs fois la même date qui s affiche et un seul et même groupe au lieu des rotations .Par contre le superviseur c est nickel .

Vous est il possible de regarder à nouveau ? pour exemple j ai ajouté le fichier avec quelques lignes anonymisées (la macro est le 4eme bouton de la première feuille)

Cordialement

Hello,

Je comprends pas du coup, un peu plus de détail ?

@+

Bonjour Baroute ,

Effectivement peut etre n etais je pas suffisament precise dans ma demande .Au niveau du resultat j ai cela

Or ce que je souhaiterais c est que :

- le 17/06

==> vu que c est Chocolat le sup , je ne pourrais planifier que Choux, patate , Brocoli et cèleri (source repart effectif)

==> or seul Patate ne peut être planifier puisqu'il est éligible à partir du 14/06 (source date analyse contrat)

==> après vérification il est bien présent ce jour là (source planning abs)

==> donc le 17/06 je n aurais que Patate en résultat et il ne redeviendra éligible qu'à partir du 17/07

- le 18/06

==> vu que c est Chocolat le sup , je ne pourrais planifier que Choux, patate , Brocoli et cèleri (source repart effectif)

==> or seul Brocoli ne peut être planifier puisqu'il est éligible à partir du 18/06 (source date analyse contrat) et que Patate ne l ai plus et ne le redeviendra que le 17/07

==> après vérification il est bien présent ce jour là (source planning abs)

==> donc le 18/06 je n aurais que Brocoli en résultat et il ne redeviendra éligible qu'à partir du 18/07

- le 19/07

==> admettons que c est Vanille le sup , je ne pourrais planifier que Carotte, patate , Brocoli et cèleri (source repart effectif)

==> or Patate et Brocoli sont éligible (puisque de nouveau dispo suite au precedente planif

==> après vérification il est bien présent ce jour là (source planning abs)

==> donc le 19/07 je n aurais que Patate et Brocoli en résultat et ils ne redeviendront éligible qu'à partir du 20/07

La liste des collab n est qu un exemple puisqu elle contient au minimum 150 lignes. Si personne n est disponible sur la date de planif il ne faut mettre personne.Et il ne peux pas avoir plus de 5 personnes par date .

En espérant avoir été plus précise et en vous remerciant de votre aide

Cordialement

Hello,

Essaie avec ça, c'est dans le module 10, mais je commence à plus y voir clair

Il faut plus de datas étant donné qu'il y a 30 jours après une affectation

@+

Bonjour ,

Je n arrive pars à ouvrir la macro pour l incorporer dans le fichier exemple comprenant plus de données.

Voici une matrice avec plus de date

En vous remerciant par avance de votre retour

Cordialement

Hello,

Ca a l'air OK enfin je crois...

Je pense que j'abandonne si ce n'est pas le résultat attendu

@+

mon essai (module12)

Bonjour ,

Je tenais à remercier BAROUTE 78 et BsAlv pour leur aide .C'est la solution de BsAlv qui est la plus cohérente avec le résultat que je souhaitais .

Encore une fois Merci

Cordialement