Une application pour distribuer les tâches à du personnel disponible

Pour montrer comment Access se prête à la résolution de problèmes de gestion

Ce tutoriel propose un algorithme pour distribuer des tâches entre bénévoles en répartissant les appels de manière équitable.

Pour l'aspect « Access », on abordera :

- la technique des formulaires pères/fils : en l'occurrence, un formulaire père indépendant (sans source) avec 28 fils qui utilisent la même table ;

- les zones de liste dans un formulaire fils pour lesquelles le choix se restreint selon l'enregistrement actif du père et les choix déjà opérés dans un formulaire « frère » ;

- quelques acrobaties de VBA.

Il s'adresse à des utilisateurs expérimentés : seules les parties techniques un peu délicates sont expliquées en détail.

Pour réagir au contenu de cet article, un espace de dialogue vous est proposé sur le forum Commentez Donner une note à l'article (5) 

Article lu   fois.

L'auteur

Profil ProSite personnel

Liens sociaux

Viadeo Twitter Facebook Share on Google+   

I. Le contexte de l'exemple

Il s'agit d'une entreprise qui fonctionne avec du personnel bénévole.
Deux personnes doivent assurer une permanence pour quatre plages horaires sept jours sur sept soit 06-09 ; 09-12 ; 12-15 et 15-18.

Le but est de disposer d'un programme qui établit le rôle de garde en répartissant les appels de volontaires de manière équitable : c'est-à-dire sans donner systématiquement la priorité à ceux qui sont souvent disponibles et négliger l'offre de celui qui ne peut venir qu'un jour, une semaine sur deux.

I-A. Chaque volontaire a proposé ses disponibilités, ainsi que ses desiderata

Deux exemples pour être concret :

Image non disponible

Note pour mes amis hexagonaux

Le terme « pause » équivaut, dans ce contexte à « plage horaire ».

Faire les pauses [Belgique] : travailler en équipe, par roulement. 
Exemple :
- De quelle pause es-tu cette semaine ?
- Je fais l'après-midi… (donc de 14 à 22 heures). 

Image non disponible

Autre point de vocabulaire

- ABBOTT dit : « je peux seulement venir si ANGLADE vient aussi ».

Pour désigner chacun des duettistes, j'ai choisi ce vocabulaire :
- ABBOTT est un « dépendant » ;
- ANGLADE est un « obligé ».

Image non disponible

Ces données ne sont pas figées : ce sont celles en vigueur au moment où on lance le programme qui va établir le rôle de garde pour une période à venir.

Le dépendant doit calquer son offre sur celle de son obligé.

Image non disponible

Image non disponible Les deux doivent commencer et terminer aux mêmes pauses, les jours où ils viennent ensemble.

Image non disponible Ces deux contraintes peuvent être différentes, mais, si à cause de ces contraintes,
l'obligé n'est pas sélectionné, la candidature du dépendant ne sera pas retenue.

Image non disponible Le dépendant ne peut exprimer cette contrainte : c'est celle de l'obligé qui sera prise en considération (pour garantir qu'ils terminent leur prestation ensemble). Cette case s'allume en rouge si elle est remplie.

Image non disponible Dans cet exemple, si Maigret est choisi un jeudi, il viendra seul.

Dans la réalité, il se pourrait qu'il n'y ait pas de volontaire disponible pour une pause.

Dans tVolontaires, nous avons ajouté deux volontaires fictifs (Joker) qui seront alors élus à coup sûr : ils sont « candidats » pour toutes les pauses et sans restriction :

Image non disponible

Quand un Joker est élu, c'est qu'il y a un problème d'effectif à régler.

Nous verrons plus loin qu'il s'affichera en rouge pour attirer l'attention de l'utilisateur sur cette lacune à combler.


I-B. Ce que l'on veut réaliser

En un clic, obtenir un horaire des prestations futures.

Image non disponible

II. Le raisonnement pour affecter les tâches « équitablement »

Pour chaque volontaire, on calcule un rang de priorité.

C'est la somme
- du nombre des pauses pour lesquelles il est candidat et
- le nombre de pauses pour lesquelles il a effectivement été sélectionné dans le passé.

Donc plus un candidat propose ses services et plus il a été choisi pour prester, plus son rang est élevé.

Pour choisir l'effectif d'une pause, le programme d'affectation donne la priorité aux deux candidats qui ont le plus petit rang : on privilégie ainsi ceux qui ont été moins souvent élus !

Si un élu est aussi candidat pour la pause suivante de la journée, il devient prioritaire pour celle-ci. (Ceux qui sont déjà sur place et qui sont candidats sont élus d'office.)

Le programme vérifie que les volontaires qui dépendent d'un autre (Simenon/Maigret) sont élus simultanément et que deux exclus mutuels (Hemingway/Arnothy) ne forment pas la paire retenue.

III. Le modèle de données

Quatre tables :

Image non disponible

Les colonnes Dim06-09 => Sam15-18 sont de type booléen.

Les colonnes Rang et RangJour sont calculées dynamiquement, elles servent à gérer l'ordre de priorité lors de l'attribution des rôles. Idem pour MotifRejet qui mentionnera pourquoi le candidat n'a pas été retenu.

IV. Les références utiles

Image non disponible

V. Le formulaire fVolontaires

Image non disponible

Image non disponible Cette zone de liste permet de choisir le volontaire à afficher.

Le code associé à l'événement après mise à jour :

 
Sélectionnez
Public Sub cboVolontaire_AfterUpdate()
 'On cherche l'enregistrement qui contient cette valeur
  Me.Recordset.FindFirst "tVolontairesPK =" & Me.cboVolontaire
End Sub

Si l'utilisateur introduit un nom qui ne fait pas partie de la liste, ce message s'affiche :

Image non disponible

Voici le code qui est exécuté lorsque le choix n'est pas dans la liste :

 
Sélectionnez
Private Sub cboVolontaire_NotInList(NewData As String, Response As Integer)
    MsgBox NewData & " ? Mais ce volontaire n'existe pas !" & vbCrLf & "Veuillez choisir une personne de la liste.", vbExclamation
    Me.cboVolontaire.Undo
    Response = acDataErrContinue
End Sub

Image non disponible Ce contrôle est indépendant, sa source ="(" & StatutDuCandidat([txttVolontairesPK]) & ")"

fait appel à la fonction StatutDuCandidat pour afficher s'il s'agit d'un volontaire « ordinaire », « dépendant » ou « obligé ».

 
Sélectionnez
Public Function StatutDuCandidat(idCandidat As Long) As String
  Dim LngPartenaire As Long
  LngPartenaire = Nz(DLookup("tVolontairesFK", "tCoVolObli", "VolObliFK=" & idCandidat), 0)
  If LngPartenaire <> 0 Then
      StatutDuCandidat = "Obligé"
    Else
      LngPartenaire = Nz(DLookup("VolObliFK", "tCoVolObli", "tVolontairesFK=" & idCandidat), 0)
      If LngPartenaire <> 0 Then
          StatutDuCandidat = "Dépendant"
        Else
          StatutDuCandidat = "Ordinaire"
      End If
  End If
End Function

Il est affecté d'une mise en forme conditionnelle :

Image non disponible

Image non disponible Il s'agit d'un sous-formulaire fils :

Image non disponible

La zone de liste propose les volontaires autres que lui-même et les jokers :

Image non disponible

Image non disponible Il s'agit d'un sous-formulaire fils :

Image non disponible

La zone de liste propose les volontaires autres que lui-même, les jokers et ceux qu'il a désignés comme covolontaire obligé :

Image non disponible

Ne pas oublier d'actualiser le contenu des zones de liste

- à chaque lecture d'un enregistrement

 
Sélectionnez
Private Sub Form_Current()
  Me.cboVolontaire = Null
  Me.CTNRsfCoVolExclus.Form.cboCovolExclu.RowSource = _
              Me.CTNRsfCoVolExclus.Form.cboCovolExclu.RowSource
  Me.CTNRsfCoVolObli.Form.cboCovolObli.RowSource = _
              Me.CTNRsfCoVolObli.Form.cboCovolObli.RowSource
End Sub

- quand on modifie le contenu de cboCovolObli dans le sous-formulairesfCoVolObli

 
Sélectionnez
Private Sub cboCovolObli_AfterUpdate()
  Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource = _
                Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource
End Sub
Private Sub Form_AfterDelConfirm(Status As Integer)
  Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource = _
                  Me.Parent!CTNRsfCoVolExclus.Form!cboCovolExclu.RowSource
End Sub

Image non disponible Un clic sur l'un de ces boutons remplit ou vide toutes les cases à cocher.

 
Sélectionnez
Private Sub BtTout_Click()
  Dim ctl As Control
  For Each ctl In Me.Controls
    If ctl.Name Like "cc*" Then ctl = True
  Next ctl
End Sub

Private Sub BtRien_Click()
  Dim ctl As Control
  For Each ctl In Me.Controls
    If ctl.Name Like "cc*" Then ctl = False
  Next ctl
End Sub

VI. Le formulaire fAffectations

VI-A. Présentation

Image non disponible

Les volontaires « ordinaires » s'affichent en vert : Image non disponible

Les « dépendants » en bleu clair : Image non disponible

Les « obligés » en bleu foncé : Image non disponible

Image non disponible

Lorsqu'un « dépendant » est sélectionné, son obligé l'accompagne nécessairement Image non disponible.

Un « obligé » peut être sélectionné seul Image non disponible si le dépendant n'est pas disponible à ce moment.

Le manque de volontaire pour une pause s'affiche en rouge Image non disponible.

Ces couleurs résultent de la mise en forme conditionnelle du contrôle txtRetenu dans le sous-formulaire sfPause :

Image non disponible

L'espace réservé à chaque pause permet de voir les deux volontaires qui ont été retenus.

Dans chacune des 28 pauses affichées, un clic sur le bouton Image non disponible permet d'afficher les candidats non retenus ainsi que le motif de non-sélection :

Image non disponible

Le formulaire fNonElus vient s'afficher juste en dessous du bouton cliqué.

On utilise pour cela la technique mise au point par Arkham46 dans cette contribution.

VI-B. Particularités techniques

Image non disponible

C'est un formulaire père indépendant (sans source)

Image non disponible

qui contient 28 fois le même sous-formulaire fils sfPause (4 pauses X 7 jours).

Chacun d'eux va afficher la portion ad hoc de la table tAffectation.

Par exemple celui marqué Image non disponible est dans le conteneur CTNR12 :

Image non disponible

La coordination père/fils s'opère

- pour le fils : sur le contenu des colonnes AffDate et AffPause ;
- pour le père : les contrôles [txtDate1] Image non disponible et [txt09-12] Image non disponible.

Les 28 conteneurs sont construits sur le même moule : CTNRij
- avec i qui indique la ligne (les 7 jours)

- avec j qui indique la pause (1 = 06-09, … , 4 = 15-18).

Les contrôles [txtDate1] à [txtDate7] ont une source qui se réfère au contenu de [txtDateDepart] Image non disponible, le seul contrôle auquel l'utilisateur a accès.

Ainsi, [txtDate1] = [txtDateDepart] + 0, … , [txtDate4] = [txtDateDepart] + 3, … , [txtDate7] = [txtDateDepart] + 6.

C'est donc la mise à jour d'un seul contrôle [txtDateDepart] qui déclenche l'affichage des 28 équipes sélectionnées.

Par défaut, c'est le lundi de la semaine actuellement en cours qui s'affiche :

Image non disponible
 
Sélectionnez
Public Function LundiPasse() As Date
  LundiPasse = Date
  If Format(LundiPasse, "dddd") <> "lundi" Then
    Do Until Format(LundiPasse, "dddd") = "lundi"
      LundiPasse = LundiPasse - 1
    Loop
  End If
End Function

Les deux boutons Image non disponible servent à ajouter ou retrancher 7 jours à la date saisie dans [txtDateDepart].

Le code du clic sur le bouton Image non disponible d'un des 28 sous-formulaires sfPause mérite le détour (une des acrobaties annoncées dans le synopsis) :

 
Sélectionnez
1.
2.
3.
4.
5.
6.
7.
8.
9.
Private Sub btNonElus_Click()
  Dim strRef() As String
  strRef = Split(Me.Parent.ActiveControl.LinkMasterFields, ";")
  gvDetailDate = Me.Parent(strRef(0))
  gvDetailPause = Me.Parent(strRef(1))
  If CurrentProject.AllForms("fNonElus").IsLoaded Then DoCmd.Close acForm, "fNonElus"
  DoCmd.OpenForm "fNonElus", , , , , acHidden
  PositionForm Forms("fNonElus"), Me.btNonElus
End Sub

Commentaires du code

2 : on définit une variable tableau pour utiliser la fonction Split().

3 : si l'utilisateur a cliqué sur le bouton de la 2e ligne, 2e colonne, alors Me.Parent.ActiveControl.LinkMasterFields correspond au texte marqué d'une flèche

Image non disponible

Donc Ref(0) reçoit « [txtDate2] » et Ref(1) reçoit « [txt09-12] ».

4-5 : et Me.Parent(Ref(0)) vaut « 23/02/2016 » ; Me.Parent(Ref(1)) vaut « 09-12 ».
Ces deux valeurs sont mémorisées dans deux variables globales (gvDetailDate et gvDetailPause).

6-8 : on ouvre le formulaire fNonElus qui a cette requête comme source :

Image non disponible

VII. Le formulaire fAffecter

Image non disponible

Il permet d'établir le rôle des volontaires en renseignant une date à venir et une durée.

Un clic sur le bouton Image non disponible aura pour effet :

- de supprimer dans la table tAffectations tous les enregistrements (éventuels) à partir de la date mentionnée ;

- de « recalculer » les affectations pour la période en fonction des desiderata actuels des volontaires ;

- d'afficher le formulaire fAffectations à partir de la date.

 
Sélectionnez
Option Compare Database
Option Explicit

Private Sub btGenerer_Click()
  Dim I   As Integer
  'Vérifier que la demande est correctement complétée
  If IsNull(Me.txtDateDepart) + IsNull(Me.txtNbreJrs) < 0 Then
      MsgBox "Veuillez compléter les deux champs.", vbCritical
      Exit Sub
  End If
  'Purge éventuelle de la table tAffectations
  '------------------------------------------
  DoCmd.SetWarnings False
  DoCmd.RunSQL "Delete AffDate FROM tAffectations WHERE AffDate>=#" & Format(Me.txtDateDepart, "mm/dd/yyyy") & "#;"
  DoCmd.SetWarnings True
  '(Re)créer les enregistrements pour chacun des jours de la période
  For I = 0 To Me.txtNbreJrs - 1
      Call AffectationsDuJour(Me.txtDateDepart + I)
  Next I
  'Afficher le résultat
  DoCmd.OpenForm "fAffectations"
  Forms!fAffectations!txtDateDepart = Me.txtDateDepart
End Sub

Les commentaires inclus dans le code devraient suffire comme explications.

La routine AffectationsDuJour() est expliquée en détail dans le chapitre suivant.

VIII. La routine AffectationsDuJour ()

C'est l'algorithme qui va déterminer quels sont les deux candidats prioritaires pour chacune des pauses d'une journée.

VIII-A. La structure

Image non disponible

VIII-B. Le code

 
Sélectionnez
Public Sub AffectationsDuJour(DateJ As Date)
  Call RecalculDesRangs
  Call CreerLaStructureDuJour(DateJ)
  Call SelectionDeLaPaireDeCandidats(DateJ)
End Sub

VIII-B-1. Sub RecalculDesRangs()

Image non disponible
 
Sélectionnez
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.
Public Sub RecalculDesRangs()
  '-------------------------------
  'Mise à jour du rang de priorité
  '-------------------------------
   
  Dim oRst As DAO.Recordset
  Dim oFld As DAO.Field
     'Compter les pauses  il est volontaire
  Set oRst = CurrentDb.OpenRecordset("tVolontaires")
  oRst.MoveFirst
  Do Until oRst.EOF
    oRst.Edit
    oRst("Rang") = 0
    oRst.Update
    For Each oFld In oRst.Fields
      If oFld.Name Like "???##-##" Then
          oRst.Edit
          oRst("Rang") = oRst("rang") - oRst(oFld.Name)
          oRst.Update
      End If
    Next oFld
      'Ajouter le compte de ses prestations anciennes
    oRst.Edit
    oRst("Rang") = oRst("Rang") + DCount("*", "tAffectations", "tVolontairesFK=" & oRst("tVolontairesPK") _
                                               & " AND RangJour<=0 and MotifRejet =""""")
    oRst.Update
    oRst.MoveNext
  Loop
  'Forcer la priorité des Jokers
  DoCmd.SetWarnings False
  DoCmd.RunSQL "UPDATE tVolontaires SET Rang = 1E+34 WHERE VolNom Like ""Joker*"";"
  DoCmd.SetWarnings True
  'Sortie
  oRst.Close
  Set oRst = Nothing
End Sub 

Commentaires du code

33 : on affecte un nombre très grand au rang des jokers, pour s'assurer qu'ils seront seulement choisis en dernier ressort.

VIII-B-2. Sub CreerLaStructureDuJour()

Image non disponible
 
Sélectionnez
1.
2.
3.
4.
5.
6.
7.
8.
9.
10.
11.
12.
13.
14.
15.
16.
17.
18.
19.
20.
21.
22.
23.
24.
Public Sub CreerLaStructureDuJour(DateJ As Date)
  '--------------------------------
  'Créer la structure d'une journée
  '--------------------------------
  
  Dim strCharnieres As String
  Dim I As Integer
  Dim strSql As String
  Dim strNomColonne As String
  
  strCharnieres = "06-09-12-15-18"
  For I = 1 To 10 Step 3
    'Nom de la colonne de tVolontaire
    strNomColonne = Left(Format(DateJ, "dddd"), 3) & Mid(strCharnieres, I, 5)
    'Ajout des candidats
    DoCmd.SetWarnings False
    strSql = "INSERT INTO tAffectations ( AffDate, AffPause, tVolontairesFK, RangJour ) " _
          & "SELECT #" & Format(DateJ, "mm/dd/yyyy") & "# AS Expr1, """ & Mid(strCharnieres, I, 5) & """ AS Expr2, tVolontairesPK,Rang " _
          & "FROM tVolontaires " _
          & "WHERE [" & strNomColonne & "]=True;"
    DoCmd.RunSQL strSql
    DoCmd.SetWarnings True
  Next I
End Sub

Commentaires du code

15 : selon les valeurs successives de i, Mid(Charnieres, i, 5) vaudra successivement 06-09,09-12

18-21 : la requête construite à la volée pour le 1er février 2016, pause 06-09, aura cet aspect :

Image non disponible

VIII-B-3. Sub SelectionDeLaPaireDeCandidats()

Image non disponible
 
Sélectionnez
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.
Public Sub SelectionDeLaPaireDeCandidats(DateJ As Date)
  '---------------------------------------
  'Sélection des candidats pause par pause
  '---------------------------------------

  Dim strCharnieres As String
  Dim I As Integer
  Dim strPause As String
  Dim strPauseSuivante As String
  Dim strSql As String
  Dim oQry As DAO.QueryDef
  
  strCharnieres = "06-09-12-15-18"
 
  For I = 1 To 10 Step 3
    strPause = Mid(strCharnieres, I, 5)
    'Déterminer la pause suivante (servira à ReportPourPauseSuivanteer les 2 élus dans la pause suivante
       's'ils sont aussi candidats
    If I <= 7 Then
        strPauseSuivante = Mid(strCharnieres, I + 3, 5)
      Else
        strPauseSuivante = ""
    End If
    'Écarter les candidats qui ont déjà rempli leur quota de prestations
    strSql = "UPDATE tAffectations SET MotifRejet = RespectDesContraintesDuVolontaire([tVolontairesFK],#" _
                                                      & Format(DateJ, "mm/dd/yyyy") _
                                                      & "#,""" & strPause & """) " _
            & "WHERE AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# AND AffPause=""" & strPause & """;"
    DoCmd.SetWarnings False
    DoCmd.RunSQL strSql
    DoCmd.SetWarnings True
    'Actualiser rPauseEnCours (une requête enregistrée, => simplifier le code)
    strSql = "SELECT tAffectationsPK, AffDate, AffPause, tVolontairesFK, RangJour, MotifRejet, VolNom " _
                & "FROM tVolontaires INNER JOIN tAffectations ON tVolontaires.tVolontairesPK = tAffectations.tVolontairesFK  " _
                & "WHERE AffDate = #" & Format(DateJ, "mm/dd/yyyy") & "# And AffPause =""" & strPause & """ And MotifRejet="""" " _
                & "ORDER BY  RangJour, tVolontairesFK;"
    Set oQry = CurrentDb.QueryDefs("rPauseEnCours")
    oQry.SQL = strSql
    'Retenir les 2 volontaires pour chaque pause
    Call ElectionDeLaPaire(DateJ, strPause)
    'ReportPourPauseSuivante de priorité
    If strPauseSuivante <> "" Then Call ReportPourPauseSuivante(strPauseSuivante)
  Next I
End Sub 

Commentaires du code

26-30 : le code correspond à cette requête (1/2/2016, pause 06-09)

Image non disponible

La fonction RespectDesContraintesDuVolontaire() est détaillée plus loin.

35-38 : on crée une requête qui extrait la tranche de la pause actuelle dans tPrestations :

Image non disponible

Ceci pour faciliter l'écriture du code à certains endroits du programme.

VIII-B-4. Sub ElectionDeLaPaire()

Image non disponible
 
Sélectionnez
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.
Public Sub ElectionDeLaPaire(DateJ As Date, Pause As String)

  '--------------------------------------------------
  'Retenir les 2 volontaires pour chaque pause
  'en respectant les contraintes de dépendant/obligé
  'et d'exclusion mutuelle
  '--------------------------------------------------
  Dim oRst As DAO.Recordset
  Dim oRst2 As DAO.Recordset
  Dim intNbreRetenus As Integer
  Dim strSql As String
  Dim oQry As DAO.QueryDef

  Set oRst = CurrentDb.OpenRecordset("rPauseEnCours")
  oRst.MoveFirst
  intNbreRetenus = DCount("tAffectationsPK", "rPauseEnCours", "RangJour <= 0")
  
  'Boucle pour retenir les 2 candidats prioritaires
  Do While intNbreRetenus < 2
    If oRst("RangJour") = -2 Then GoTo FinDesControles '(c'est le 2e membre d'une paire)
    'Traitement des paires Dépendant/Obligé
    Select Case StatutDuCandidat(oRst("tvolontairesFK"))
      Case "Dépendant"
        'l'éliminer si son obligé est absent, sinon retenir la paire
        Set oRst2 = CurrentDb.OpenRecordset("SELECT  VolObliFK FROM tCoVolObli WHERE tVolontairesFK=" & oRst("tVolontairesFK") & ";")
        oRst2.MoveFirst
        Do Until oRst2.EOF
          If DCount("*", "rPauseEnCours", "tVolontairesFK=" & oRst2("VolObliFK")) > 0 Then  'l'obligé est présent
              oRst.Edit
              oRst("RangJour") = -2
              oRst.Update
              'Mettre le rang de l'obligé à -2
              DoCmd.SetWarnings False
              DoCmd.RunSQL "UPDATE rPauseEnCours SET RangJour = -2  " _
                              & "WHERE tVolontairesFK=" & oRst2("VolObliFK") & ";"
              DoCmd.SetWarnings True
              oRst2.Close
              GoTo FinDesControles
          End If
          oRst2.MoveNext
        Loop
        oRst2.Close
        'Si on arrive ici, pas d'obligé présent pour ce dépendant
        oRst.Edit
        oRst("MotifRejet") = "ObligéAbsent"
        oRst.Update
        GoTo FinDesControles
      Case "Obligé"
        'Si son dépendant est aussi candidat, on les prend tous les deux
        Set oRst2 = CurrentDb.OpenRecordset("SELECT  tVolontairesFK FROM tCoVolObli WHERE VolObliFK=" & oRst("tVolontairesFK") & ";")
        oRst2.MoveFirst
        Do Until oRst2.EOF
          If DCount("*", "rPauseEnCours", "tVolontairesFK=" & oRst2("tVolontairesFK")) > 0 Then  'le dépendant est présent
              oRst.Edit
              oRst("RangJour") = -2
              oRst.Update
              'Mettre le rang du dépendant à -2
              DoCmd.SetWarnings False
              DoCmd.RunSQL "UPDATE rPauseEnCours SET RangJour = -2  " _
                              & "WHERE tVolontairesFK=" & oRst2("tVolontairesFK") & ";"
              DoCmd.SetWarnings True
              oRst2.Close
              GoTo FinDesControles
          End If
          oRst2.MoveNext
        Loop
        oRst2.Close
    End Select
    'N.B. On arrive ici pour tous les ordinaires et obligés seuls
    'Ce candidat est élu
    oRst.Edit
    oRst("RangJour") = 0
    oRst.Update
    'Y a-t-il une incompatibilité concernant ce candidat ?
    '----------------------------------------------------
    'Si non, on passe au suivant
    If ControleDesIncompatibilites(oRst("tVolontairesFK")) = "" Then GoTo FinDesControles
    'Si oui, éliminer les autres volontaires (éventuels) du groupe ayant une moindre priorité
    strSql = "UPDATE tAffectations SET MotifRejet = ""Incompatible"" , RangJour =1E+35 " _
                      & " WHERE AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# " _
                         & "AND AffPause=""" & Pause & """ " _
                         & "AND RangJour>0 " _
                         & "AND tVolontairesFK In(" & ControleDesIncompatibilites(oRst("tVolontairesFK")) & ");"
    DoCmd.SetWarnings False
    DoCmd.RunSQL strSql
    DoCmd.SetWarnings True
FinDesControles:
    intNbreRetenus = DCount("tAffectationsPK", "rPauseEnCours", "RangJour <= 0")
    oRst.MoveNext
  Loop

  'Retenir les 2 candidats pour cette pause
  '----------------------------------------
  Set oRst = CurrentDb.OpenRecordset("SELECT * FROM rPauseEnCours  ORDER BY RangJour;")
  oRst.MoveFirst
  oRst.Move 2
  Do Until oRst.EOF
    oRst.Edit
    If oRst("MotifRejet") = "" Then oRst("MotifRejet") = "Non prioritaire"
    oRst.Update
    oRst.MoveNext
  Loop
  
  'Sortie
  Set oQry = Nothing
  oRst.Close
  Set oRst = Nothing
  Set oRst2 = Nothing

End Sub 

Commentaires du code

15 : rappelons que la requête ramène les candidats à la pause, classés dans l'ordre de leur priorité, pour autant qu'ils n'aient pas été éliminés à l'étape précédente.

20 : on sortira de la boucle, lorsqu'au moins deux candidats auront été élus.

23 : le statut d'un candidat va influencer le choix.

24-50 : le candidat est dépendant.
Il ne peut être retenu que si son obligé est toujours en lice.

Image non disponible

Si cette partie du code est sollicitée lors du traitement, c'est que l'obligé a une priorité inférieure à celle de ce dépendant.
Il y a peut-être déjà un autre volontaire ordinaire qui a été « élu ».

Nous avons arbitrairement décidé que lorsqu'un membre du duo dépendant/obligé avait une priorité qui le rendait éligible, il entraînait celle de son partenaire.

Nous attribuerons un rang du jour à -2 pour les deux partenaires. Ce qui entraînera la non-élection du volontaire (éventuel) élu lors du premier passage dans la boucle (il avait reçu alors un rang du jour = 0, à l'instruction 80).

26-40 : si on constate la présence de son obligé parmi les candidats encore en lice pour cette pause, on leur attribue le rang -2. On saute alors à l'instruction 116 qui nous fera sortir de la boucle : le nombre d'élus est alors au moins égal à 2 !

45-50 : si on arrive ici, c'est que le dépendant est orphelin et on l'élimine avant de passer au candidat suivant.

51-72 : le candidat est obligé.
Le raisonnement est semblable au cas précédent sauf que si le dépendant n'est pas en lice, l'obligé est traité comme un candidat ordinaire et on continue le traitement à l'instruction 73.

73-77 : si un candidat ordinaire ne fait pas partie de l'ensemble des exclus mutuels, il reçoit un rang prioritaire = 0 et on passe au candidat suivant.

Image non disponible
L'élection d'un candidat ordinaire qui fait partie d'un ensemble d'exclus mutuels entraîne l'élimination des autres membres du groupe qui ont une priorité inférieure.

La fonction ControleDesIncompatibilites()

 
Sélectionnez
Public Function ControleDesIncompatibilites(idVol As Long) As String
  Dim oRst As DAO.Recordset
  'Qui exclut-il ?
  Set oRst = CurrentDb.OpenRecordset("SELECT VolExclusFK FROM tCoVolExclus " _
                                       & "WHERE tVolontairesFK=" & idVol & ";")
  Do Until oRst.EOF
    ControleDesIncompatibilites = ControleDesIncompatibilites & oRst("VolExclusFK") & ","
    oRst.MoveNext
  Loop
  'Par qui est-il exclu ?
   Set oRst = CurrentDb.OpenRecordset("SELECT tVolontairesFK FROM tCoVolExclus " _
                                       & "WHERE VolExclusFK=" & idVol & ";")
  Do Until oRst.EOF
    ControleDesIncompatibilites = ControleDesIncompatibilites & oRst("tVolontairesFK") & ","
    oRst.MoveNext
  Loop
  oRst.Close
  Set oRst = Nothing
End Function

Par exemple pour ARNOTHY :

Image non disponible

D'une part ARNOTHY (3) ne veut pas venir si ABBOTT Jeff (1) ou FRENCH Nicci (18) vient.

Et d'autre part ni HEMINGWAY Ernest (5), ni MAIGRET Jules (7) ne veulent ARNOTHY comme coéquipière.

Lorsqu'il n'y a pas d'incompatibilité, la fonction envoie un résultat vide (« "" »).

Par exemple pour ASSOULINE :

Image non disponible

82 : s'il n'y a pas d'exclusion mutuelle, on passe au suivant.

84-91 : s'il y a exclusion mutuelle, les autres membres du groupe doivent être écartés : on met leur rang prioritaire à 1E+35 (donc ils viendront après les jokers qui ont 1E+34).
Voici la requête qui est créée à la volée, lors du traitement de ARNOTHY le 11/1/16 pour 06-09 :

Image non disponible

98-108 : quand deux candidats ont été élus, on sort de la boucle, on relit rPausesEnCours dans l'ordre des priorités croissantes, on saute les deux premiers enregistrements (les élus) et on écrit « Non prioritaire » dans la colonne MotifDuRejet si elle est encore vierge.

VIII-B-5. Sub ReportPourPauseSuivante()

Image non disponible
Image non disponible

Autre a priori de l'algorithme : le candidat élu pour une pause est systématiquement réélu pour la pause suivante (pour autant bien sûr qu'il soit candidat).

C'est cette règle qui est mise en application dans cette dernière partie du code.

 
Sélectionnez
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.
Public Sub ReportPourPauseSuivante(PauseSuivante As String)

  '---------------------------------------------------------------------------------------------------------
  'Sauf si joker, les 2 élus d'une pause deviennent prioritaires pour la pause suivante s'ils sont candidats
  '---------------------------------------------------------------------------------------------------------
  Dim oRst As DAO.Recordset
  Dim strSql As String
  
  'ReportPourPauseSuivanteer (éventuellement) les 2 élus dans la pause suivante
  Set oRst = CurrentDb.OpenRecordset("rPauseEnCours")
  oRst.MoveFirst
  Do While Not oRst.EOF
    If oRst("VolNom") <> "Joker" Then
        strSql = "UPDATE tAffectations SET RangJour = -1 " _
                      & "WHERE AffDate=#" & Format(oRst("affDate"), "mm/dd/yyyy") & "# " _
                        & "AND AffPause=""" & PauseSuivante & """ " _
                        & "AND tVolontairesFK=" & oRst("tVolontairesFK") _
                        & "AND MotifRejet="""";"
        DoCmd.SetWarnings False
        DoCmd.RunSQL strSql
        DoCmd.SetWarnings True
    End If
    If oRst.AbsolutePosition = 1 Then Exit Do
    oRst.MoveNext
  Loop
  'Sortie
  oRst.Close
  Set oRst = Nothing
End Sub  

15-19 : voici par exemple la requête qui serait générée à l'issue de la pause 06-09 du 1/1/2017 pour CHRISTIE (15) qui a été élue.

Image non disponible
Image non disponible

Remarquez la mise à -1 de RangJour.

S'il s'avère que les deux volontaires sont aussi candidats pour la pause suivante, ils seront élus d'office pour cette pause.

En effet lors du traitement de cette pause par la sub Election(), tout le processus de validation sera court-circuité :

Image non disponible

Par contre, si seulement l'un d'eux est « reportable », il se pourrait qu'il ne soit pas finalement élu.
En effet, si un membre d'une paire Obligé/Dépendant est le second choisi, il entrainera son coéquipier avec lui (ils auront -2 comme rang).


VIII-B-6. La fonction RespectDesContraintesDuVolontaire()

 
Sélectionnez
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.
Public Function RespectDesContraintesDuVolontaire(idVol As Long, DateJ As Date, Pause As String) As String
  
  On Error GoTo GestionErreurs
  Dim vntRes As Variant
  Dim intNbrePauses As Integer
  Dim dtnPrestaPrec As Date
  Dim intMaxPresta As Integer
  Dim oRst As DAO.Recordset

  'Contrainte MaxPauses
  '--------------------
  vntRes = DLookup("MaxPauses", "tVolontaires", "tVolontairesPK=" & idVol)
  If Not IsNull(vntRes) Then
     'Combien de pauses aujourd'hui ?
     intNbrePauses = DCount("tAffectationsPK", "tAffectations", _
                    "AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# And tVolontairesFK=" & idVol _
                              & " AND AffPause <= """ & Pause & """ AND MotifRejet=""""")
    If intNbrePauses >= vntRes Then
         RespectDesContraintesDuVolontaire = ">MaxPauses"
         Exit Function
     End If
  End If
  'Contrainte Espace journées
  '--------------------------
  vntRes = DLookup("NbreMinInter", "tVolontaires", "tVolontairesPK=" & idVol)
  If Not IsNull(vntRes) Then
      'Recherche date précédentes prestations
      dtnPrestaPrec = Nz(DMax("AffDate", "tAffectations", _
                    "AffDate<#" & Format(DateJ, "mm/dd/yyyy") _
                         & "# And tVolontairesFK=" & idVol & " AND MotifRejet="""""), #1/1/1900#)
      'Vérif espace
      If DateJ - dtnPrestaPrec <= vntRes Then
          RespectDesContraintesDuVolontaire = "<EspaceJrs"
          Exit Function
      End If
  End If
  'Maximum prestations/semaine
  '---------------------------
  intMaxPresta = Nz(DLookup("NbreMaxJrsSem", "tVolontaires", "tVolontairesPK=" & idVol), 1000)
  If intMaxPresta <> 1000 Then
    'Sommes-nous <>lundi ?
     If Format(DateJ, "dddd") <> "lundi" Then
         'Rechercher date précédent lundi
         vntRes = DateJ
         Do Until Format(vntRes, "dddd") = "lundi"
           vntRes = vntRes - 1
         Loop
         'Compter les prestations depuis lundi
         Set oRst = CurrentDb.OpenRecordset("SELECT DISTINCT AffDate FROM tAffectations " _
                                               & "WHERE AffDate>=#" & Format(vntRes, "mm/dd/yyyy") _
                                               & "# AND tVolontairesFK=" & idVol _
                                               & " AND MotifRejet ="""";")
         'Vérifier le non-dépassement
         oRst.MoveLast
         If oRst.RecordCount >= intMaxPresta Then
             RespectDesContraintesDuVolontaire = ">PrestaJrs"
             Exit Function
         End If
     End If
  End If
GestionErreurs:
  Select Case Err.Number
    Case 0 ' pas d'erreur
      Exit Function
    Case 3021 'pas d'enregistrement de prestations passées
      Exit Function
    Case Else
      MsgBox "Erreur dans RespectDesContraintesDuVolontaire : " & Err.Number & " " & Err.Description & " !"
  End Select
  
End Function

Les commentaires inclus dans le code devraient suffire à la compréhension.

30 et 41 : remarquez l'utilisation de la fonction Nz() qui substituera une valeur extrême (1/1/1900 pour une date de précédente prestation ; 1000 pour un nombre maximum de pauses par jour) quand il y a risque d'un retour Null.

IX. Téléchargement

X. Remerciements

Merci à Jean-Philippe AMBROSINO (argyronet) de m'avoir conseillé des améliorations à apporter à la syntaxe de mon code.

Merci à Christophe LOUVET (chrtophe) et Winjerome pour leurs remarques.

Merci à Fabien (f-leb) pour la relecture orthographique.

Vous avez aimé ce tutoriel ? Alors partagez-le en cliquant sur les boutons suivants : Viadeo Twitter Facebook Share on Google+   

  

Les sources présentées sur cette page sont libres de droits et vous pouvez les utiliser à votre convenance. Par contre, la page de présentation constitue une œuvre intellectuelle protégée par les droits d'auteur. Copyright © 2016 Claude Leloup. Aucune reproduction, même partielle, ne peut être faite de ce site et de l'ensemble de son contenu : textes, documents, images, etc. sans l'autorisation expresse de l'auteur. Sinon vous encourez selon la loi jusqu'à trois ans de prison et jusqu'à 300 000 € de dommages et intérêts.