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

Claude Leloup

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

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

- Auteur : Claude Leloup

- Parution : 17 mars 2016

- Mise à jour : 20 mars 2016

- Licence : 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.

Sommaire

- I. Le contexte de l'exemple

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

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

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

- III. Le modèle de données

- IV. Les références utiles

- V. Le formulaire fVolontaires

- VI. Le formulaire fAffectations

- VI-A. Présentation

- VI-B. Particularités techniques

- VII. Le formulaire fAffecter

- VIII. La routine AffectationsDuJour ()

- VIII-A. La structure

- VIII-B. Le code

- VIII-B-1. Sub RecalculDesRangs()

- VIII-B-2. Sub CreerLaStructureDuJour()

- VIII-B-3. Sub SelectionDeLaPaireDeCandidats()

- VIII-B-4. Sub ElectionDeLaPaire()

- VIII-B-5. Sub ReportPourPauseSuivante()

- VIII-B-6. La fonction RespectDesContraintesDuVolontaire()

- IX. Téléchargement

- X. Remerciements

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 :

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

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é ».

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

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

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.

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.

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 :

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.

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 :

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

V - Le formulaire fVolontaires

Cette zone de liste permet de choisir le volontaire à afficher.

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

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 :

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

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

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é ».

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 :

Il s'agit d'un sous-formulaire fils :

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

Il s'agit d'un sous-formulaire fils :

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

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

- à chaque lecture d'un enregistrement

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

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

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

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

Les volontaires « ordinaires » s'affichent en vert :

Les « dépendants » en bleu clair :

Les « obligés » en bleu foncé :

Lorsqu'un « dépendant » est sélectionné, son obligé l'accompagne nécessairement .
Un « obligé » peut être sélectionné seul si le dépendant n'est pas disponible à ce moment.
Le manque de volontaire pour une pause s'affiche en rouge .

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

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 permet d'afficher les candidats non retenus ainsi que le motif de non-sélection :

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

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

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é est dans le conteneur CTNR12 :

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] et [txt09-12] .

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] , 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 :

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 servent à ajouter ou retrancher 7 jours à la date saisie dans [txtDateDepart].

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

1. Private Sub btNonElus_Click()

2. Dim strRef() As String

3. strRef = Split(Me.Parent.ActiveControl.LinkMasterFields, ";")

4. gvDetailDate = Me.Parent(strRef(0))

5. gvDetailPause = Me.Parent(strRef(1))

6. If CurrentProject.AllForms("fNonElus").IsLoaded Then DoCmd.Close acForm, "fNonElus"

7. DoCmd.OpenForm "fNonElus", , , , , acHidden

8. PositionForm Forms("fNonElus"), Me.btNonElus

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

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 :

VII - Le formulaire fAffecter

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

Un clic sur le bouton 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.

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

VIII-B - Le code

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

VIII-B-1 - Sub RecalculDesRangs()

1. Public Sub RecalculDesRangs()

2. '-------------------------------

3. 'Mise à jour du rang de priorité

4. '-------------------------------

5. Dim oRst As DAO.Recordset

6. Dim oFld As DAO.Field

7. 'Compter les pauses où il est volontaire

8. Set oRst = CurrentDb.OpenRecordset("tVolontaires")

9. oRst.MoveFirst

10. Do Until oRst.EOF

11. oRst.Edit

12. oRst("Rang") = 0

13. oRst.Update

14. For Each oFld In oRst.Fields

15. If oFld.Name Like "???##-##" Then

16. oRst.Edit

17. oRst("Rang") = oRst("rang") - oRst(oFld.Name)

18. oRst.Update

19. End If

20. Next oFld

21. 'Ajouter le compte de ses prestations anciennes

22. oRst.Edit

23. oRst("Rang") = oRst("Rang") + DCount("*", "tAffectations", "tVolontairesFK=" & oRst("tVolontairesPK") _

24. & " AND RangJour<=0 and MotifRejet =""""")

25. oRst.Update

26. oRst.MoveNext

27. Loop

28. 'Forcer la priorité des Jokers

29. DoCmd.SetWarnings False

30. DoCmd.RunSQL "UPDATE tVolontaires SET Rang = 1E+34 WHERE VolNom Like ""Joker*"";"

31. DoCmd.SetWarnings True

32. 'Sortie

33. oRst.Close

34. Set oRst = Nothing

35. 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()

1. Public Sub CreerLaStructureDuJour(DateJ As Date)

2. '--------------------------------

3. 'Créer la structure d'une journée

4. '--------------------------------

5. Dim strCharnieres As String

6. Dim I As Integer

7. Dim strSql As String

8. Dim strNomColonne As String

9. strCharnieres = "06-09-12-15-18"

10. For I = 1 To 10 Step 3

11. 'Nom de la colonne de tVolontaire

12. strNomColonne = Left(Format(DateJ, "dddd"), 3) & Mid(strCharnieres, I, 5)

13. 'Ajout des candidats

14. DoCmd.SetWarnings False

15. strSql = "INSERT INTO tAffectations ( AffDate, AffPause, tVolontairesFK, RangJour ) " _

16. & "SELECT #" & Format(DateJ, "mm/dd/yyyy") & "# AS Expr1, """ & Mid(strCharnieres, I, 5) & """ AS Expr2, tVolontairesPK,Rang " _

17. & "FROM tVolontaires " _

18. & "WHERE [" & strNomColonne & "]=True;"

19. DoCmd.RunSQL strSql

20. DoCmd.SetWarnings True

21. Next I

22. 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 :

VIII-B-3 - Sub SelectionDeLaPaireDeCandidats()

1. Public Sub SelectionDeLaPaireDeCandidats(DateJ As Date)

2. '---------------------------------------

3. 'Sélection des candidats pause par pause

4. '---------------------------------------

5. Dim strCharnieres As String

6. Dim I As Integer

7. Dim strPause As String

8. Dim strPauseSuivante As String

9. Dim strSql As String

10. Dim oQry As DAO.QueryDef

11. strCharnieres = "06-09-12-15-18"

12. For I = 1 To 10 Step 3

13. strPause = Mid(strCharnieres, I, 5)

14. 'Déterminer la pause suivante (servira à ReportPourPauseSuivanteer les 2 élus dans la pause suivante

15. 's'ils sont aussi candidats

16. If I <= 7 Then

17. strPauseSuivante = Mid(strCharnieres, I + 3, 5)

18. Else

19. strPauseSuivante = ""

20. End If

21. 'Écarter les candidats qui ont déjà rempli leur quota de prestations

22. strSql = "UPDATE tAffectations SET MotifRejet = RespectDesContraintesDuVolontaire([tVolontairesFK],#" _

23. & Format(DateJ, "mm/dd/yyyy") _

24. & "#,""" & strPause & """) " _

25. & "WHERE AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# AND AffPause=""" & strPause & """;"

26. DoCmd.SetWarnings False

27. DoCmd.RunSQL strSql

28. DoCmd.SetWarnings True

29. 'Actualiser rPauseEnCours (une requête enregistrée, => simplifier le code)

30. strSql = "SELECT tAffectationsPK, AffDate, AffPause, tVolontairesFK, RangJour, MotifRejet, VolNom " _

31. & "FROM tVolontaires INNER JOIN tAffectations ON tVolontaires.tVolontairesPK = tAffectations.tVolontairesFK  " _

32. & "WHERE AffDate = #" & Format(DateJ, "mm/dd/yyyy") & "# And AffPause =""" & strPause & """ And MotifRejet="""" " _

33. & "ORDER BY  RangJour, tVolontairesFK;"

34. Set oQry = CurrentDb.QueryDefs("rPauseEnCours")

35. oQry.SQL = strSql

36. 'Retenir les 2 volontaires pour chaque pause

37. Call ElectionDeLaPaire(DateJ, strPause)

38. 'ReportPourPauseSuivante de priorité

39. If strPauseSuivante <> "" Then Call ReportPourPauseSuivante(strPauseSuivante)

40. Next I

41. End Sub

Commentaires du code

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

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 :

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

VIII-B-4 - Sub ElectionDeLaPaire()

1. Public Sub ElectionDeLaPaire(DateJ As Date, Pause As String)

2. '--------------------------------------------------

3. 'Retenir les 2 volontaires pour chaque pause

4. 'en respectant les contraintes de dépendant/obligé

5. 'et d'exclusion mutuelle

6. '--------------------------------------------------

7. Dim oRst As DAO.Recordset

8. Dim oRst2 As DAO.Recordset

9. Dim intNbreRetenus As Integer

10. Dim strSql As String

11. Dim oQry As DAO.QueryDef

12. Set oRst = CurrentDb.OpenRecordset("rPauseEnCours")

13. oRst.MoveFirst

14. intNbreRetenus = DCount("tAffectationsPK", "rPauseEnCours", "RangJour <= 0")

15. 'Boucle pour retenir les 2 candidats prioritaires

16. Do While intNbreRetenus < 2

17. If oRst("RangJour") = -2 Then GoTo FinDesControles '(c'est le 2e membre d'une paire)

18. 'Traitement des paires Dépendant/Obligé

19. Select Case StatutDuCandidat(oRst("tvolontairesFK"))

20. Case "Dépendant"

21. 'l'éliminer si son obligé est absent, sinon retenir la paire

22. Set oRst2 = CurrentDb.OpenRecordset("SELECT  VolObliFK FROM tCoVolObli WHERE tVolontairesFK=" & oRst("tVolontairesFK") & ";")

23. oRst2.MoveFirst

24. Do Until oRst2.EOF

25. If DCount("*", "rPauseEnCours", "tVolontairesFK=" & oRst2("VolObliFK")) > 0 Then  'l'obligé est présent

26. oRst.Edit

27. oRst("RangJour") = -2

28. oRst.Update

29. 'Mettre le rang de l'obligé à -2

30. DoCmd.SetWarnings False

31. DoCmd.RunSQL "UPDATE rPauseEnCours SET RangJour = -2  " _

32. & "WHERE tVolontairesFK=" & oRst2("VolObliFK") & ";"

33. DoCmd.SetWarnings True

34. oRst2.Close

35. GoTo FinDesControles

36. End If

37. oRst2.MoveNext

38. Loop

39. oRst2.Close

40. 'Si on arrive ici, pas d'obligé présent pour ce dépendant

41. oRst.Edit

42. oRst("MotifRejet") = "ObligéAbsent"

43. oRst.Update

44. GoTo FinDesControles

45. Case "Obligé"

46. 'Si son dépendant est aussi candidat, on les prend tous les deux

47. Set oRst2 = CurrentDb.OpenRecordset("SELECT  tVolontairesFK FROM tCoVolObli WHERE VolObliFK=" & oRst("tVolontairesFK") & ";")

48. oRst2.MoveFirst

49. Do Until oRst2.EOF

50. If DCount("*", "rPauseEnCours", "tVolontairesFK=" & oRst2("tVolontairesFK")) > 0 Then  'le dépendant est présent

51. oRst.Edit

52. oRst("RangJour") = -2

53. oRst.Update

54. 'Mettre le rang du dépendant à -2

55. DoCmd.SetWarnings False

56. DoCmd.RunSQL "UPDATE rPauseEnCours SET RangJour = -2  " _

57. & "WHERE tVolontairesFK=" & oRst2("tVolontairesFK") & ";"

58. DoCmd.SetWarnings True

59. oRst2.Close

60. GoTo FinDesControles

61. End If

62. oRst2.MoveNext

63. Loop

64. oRst2.Close

65. End Select

66. 'N.B. On arrive ici pour tous les ordinaires et obligés seuls

67. 'Ce candidat est élu

68. oRst.Edit

69. oRst("RangJour") = 0

70. oRst.Update

71. 'Y a-t-il une incompatibilité concernant ce candidat ?

72. '----------------------------------------------------

73. 'Si non, on passe au suivant

74. If ControleDesIncompatibilites(oRst("tVolontairesFK")) = "" Then GoTo FinDesControles

75. 'Si oui, éliminer les autres volontaires (éventuels) du groupe ayant une moindre priorité

76. strSql = "UPDATE tAffectations SET MotifRejet = ""Incompatible"" , RangJour =1E+35 " _

77. & " WHERE AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# " _

78. & "AND AffPause=""" & Pause & """ " _

79. & "AND RangJour>0 " _

80. & "AND tVolontairesFK In(" & ControleDesIncompatibilites(oRst("tVolontairesFK")) & ");"

81. DoCmd.SetWarnings False

82. DoCmd.RunSQL strSql

83. DoCmd.SetWarnings True

84. FinDesControles:

85. intNbreRetenus = DCount("tAffectationsPK", "rPauseEnCours", "RangJour <= 0")

86. oRst.MoveNext

87. Loop

88. 'Retenir les 2 candidats pour cette pause

89. '----------------------------------------

90. Set oRst = CurrentDb.OpenRecordset("SELECT * FROM rPauseEnCours  ORDER BY RangJour;")

91. oRst.MoveFirst

92. oRst.Move 2

93. Do Until oRst.EOF

94. oRst.Edit

95. If oRst("MotifRejet") = "" Then oRst("MotifRejet") = "Non prioritaire"

96. oRst.Update

97. oRst.MoveNext

98. Loop

99. 'Sortie

100. Set oQry = Nothing

101. oRst.Close

102. Set oRst = Nothing

103. Set oRst2 = Nothing

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

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.

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

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 :

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 :

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 :

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

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.

1. Public Sub ReportPourPauseSuivante(PauseSuivante As String)

2. '---------------------------------------------------------------------------------------------------------

3. 'Sauf si joker, les 2 élus d'une pause deviennent prioritaires pour la pause suivante s'ils sont candidats

4. '---------------------------------------------------------------------------------------------------------

5. Dim oRst As DAO.Recordset

6. Dim strSql As String

7. 'ReportPourPauseSuivanteer (éventuellement) les 2 élus dans la pause suivante

8. Set oRst = CurrentDb.OpenRecordset("rPauseEnCours")

9. oRst.MoveFirst

10. Do While Not oRst.EOF

11. If oRst("VolNom") <> "Joker" Then

12. strSql = "UPDATE tAffectations SET RangJour = -1 " _

13. & "WHERE AffDate=#" & Format(oRst("affDate"), "mm/dd/yyyy") & "# " _

14. & "AND AffPause=""" & PauseSuivante & """ " _

15. & "AND tVolontairesFK=" & oRst("tVolontairesFK") _

16. & "AND MotifRejet="""";"

17. DoCmd.SetWarnings False

18. DoCmd.RunSQL strSql

19. DoCmd.SetWarnings True

20. End If

21. If oRst.AbsolutePosition = 1 Then Exit Do

22. oRst.MoveNext

23. Loop

24. 'Sortie

25. oRst.Close

26. Set oRst = Nothing

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

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

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

1. Public Function RespectDesContraintesDuVolontaire(idVol As Long, DateJ As Date, Pause As String) As String

2. On Error GoTo GestionErreurs

3. Dim vntRes As Variant

4. Dim intNbrePauses As Integer

5. Dim dtnPrestaPrec As Date

6. Dim intMaxPresta As Integer

7. Dim oRst As DAO.Recordset

8. 'Contrainte MaxPauses

9. '--------------------

10. vntRes = DLookup("MaxPauses", "tVolontaires", "tVolontairesPK=" & idVol)

11. If Not IsNull(vntRes) Then

12. 'Combien de pauses aujourd'hui ?

13. intNbrePauses = DCount("tAffectationsPK", "tAffectations", _

14. "AffDate=#" & Format(DateJ, "mm/dd/yyyy") & "# And tVolontairesFK=" & idVol _

15. & " AND AffPause <= """ & Pause & """ AND MotifRejet=""""")

16. If intNbrePauses >= vntRes Then

17. RespectDesContraintesDuVolontaire = ">MaxPauses"

18. Exit Function

19. End If

20. End If

21. 'Contrainte Espace journées

22. '--------------------------

23. vntRes = DLookup("NbreMinInter", "tVolontaires", "tVolontairesPK=" & idVol)

24. If Not IsNull(vntRes) Then

25. 'Recherche date précédentes prestations

26. dtnPrestaPrec = Nz(DMax("AffDate", "tAffectations", _

27. "AffDate<#" & Format(DateJ, "mm/dd/yyyy") _

28. & "# And tVolontairesFK=" & idVol & " AND MotifRejet="""""), #1/1/1900#)

29. 'Vérif espace

30. If DateJ - dtnPrestaPrec <= vntRes Then

31. RespectDesContraintesDuVolontaire = "<EspaceJrs"

32. Exit Function

33. End If

34. End If

35. 'Maximum prestations/semaine

36. '---------------------------

37. intMaxPresta = Nz(DLookup("NbreMaxJrsSem", "tVolontaires", "tVolontairesPK=" & idVol), 1000)

38. If intMaxPresta <> 1000 Then

39. 'Sommes-nous <>lundi ?

40. If Format(DateJ, "dddd") <> "lundi" Then

41. 'Rechercher date précédent lundi

42. vntRes = DateJ

43. Do Until Format(vntRes, "dddd") = "lundi"

44. vntRes = vntRes - 1

45. Loop

46. 'Compter les prestations depuis lundi

47. Set oRst = CurrentDb.OpenRecordset("SELECT DISTINCT AffDate FROM tAffectations " _

48. & "WHERE AffDate>=#" & Format(vntRes, "mm/dd/yyyy") _

49. & "# AND tVolontairesFK=" & idVol _

50. & " AND MotifRejet ="""";")

51. 'Vérifier le non-dépassement

52. oRst.MoveLast

53. If oRst.RecordCount >= intMaxPresta Then

54. RespectDesContraintesDuVolontaire = ">PrestaJrs"

55. Exit Function

56. End If

57. End If

58. End If

59. GestionErreurs:

60. Select Case Err.Number

61. Case 0 ' pas d'erreur

62. Exit Function

63. Case 3021 'pas d'enregistrement de prestations passées

64. Exit Function

65. Case Else

66. MsgBox "Erreur dans RespectDesContraintesDuVolontaire : " & Err.Number & " " & Err.Description & " !"

67. End Select

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

La db en version Access2000 se trouve ici.

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.