XL 2016 Répartition équitable de binômes

[halecs93]

Bonjour,

Je travaille toujours sur un fichier me permettant de répartir le plus équitablement possible des personnes. Le but étant de créer des binômes différents à affecter les samedis.

J'ai, je crois, pas mal avancé, mais je n'arrive pas à finaliser cet aspect "équitable".

Quelqu'un aurait une proposition plus fiable que la mienne ?

Un grand merci.

 

[halecs93]

La macro avec 3 Dictionary :

Sub Tirages()
Dim tablo As Range, nNom%, delai%, dferie As Object, c As Range, dinterdit As Object
Dim d As Object, col%, nSam%, r1%, r2%, txt$, rejet As Boolean, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
delai = 42 'au moins 42 jours avant de réutiliser un nom
'---jours fériés à éliminer---
Set dferie = CreateObject("Scripting.Dictionary")
For Each c In [feries]
    If Weekday(c) = 7 Then dferie(c.Value) = ""
Next c
'---binômes interdits---
Set dinterdit = CreateObject("Scripting.Dictionary")
For Each c In [Tableau5].Columns(1).Cells
    dinterdit(c & vbLf & c(1, 2)) = ""
    dinterdit(c(1, 2) & vbLf & c) = ""
Next c
Application.ScreenUpdating = False
Randomize
1 Set d = CreateObject("Scripting.Dictionary")
With Sheets("CALENDRIER").Range("A5:Y35")
    '---RAZ---
    For col = 3 To 25 Step 2
        .Columns(col) = ""
    Next col
    '---tirages aléatoires---
    For col = 2 To 24 Step 2
        For Each c In .Columns(col).Cells
            If IsDate(c) Then
                If Weekday(c) = 7 Then
                    If Not dferie.exists(c.Value) Then
                        nSam = nSam + 1
                        Do
                            r1 = 1 + Int(Rnd * nNom)
                            r2 = 1 + Int(Rnd * nNom)
                            txt = tablo(r1, 1) & vbLf & tablo(r2, 1)
                            rejet = r1 = r2 Or dinterdit.exists(txt) Or c < d(r1) Or c < d(r2) 'cette variable fait gagner du temps
                            If Not rejet Then
                                c(1, 2) = txt
                                ecart = Application.Max(tablo) - Application.Min(tablo)
                            End If
                        Loop While rejet Or ecart > 1
                        d(r1) = c + delai 'mémorise la dernière date limite du 1er nom
                        d(r2) = c + delai 'mémorise la dernière date limite du 2ème nom
                    End If
                End If
            End If
    Next c, col
End With
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1 'si nécessaire...
End Sub

Grand merci.

Je vais conserver les deux versions et voir laquelle est la plus efficace à la longue.

 

[job75]

Bonjour halecs93, le forum,

Je vais conserver les deux versions et voir laquelle est la plus efficace à la longue.

Les 2 solutions sont efficaces mais avec les 3 Dictionnary c'est beaucoup plus simple.

Et donc plus rapide.

A+

 

[job75]

Pour le bouclage sans fin signalé au post #30.

Il est dû bien sûr à la boucle Do/Loop et au fait que dans cette configuration des valeurs il n'est pas possible d'obtenir un écart égal à 1.

On pourrait facilement relancer automatiquement le processus pour obtenir une solution mais je trouve préférable de le faire manuellement après la touche <échap>.

 

[job75]

Bonjour halecs93, le forum,

Bon il est évident * que quand nSam est multiple de nNom on ne peut pas avoir ecart = 1.

Donc au post #28 je viens de supprimer la ligne :

If nSam Mod nNom = 0 And ecart Then GoTo 1 'si nécessaire...

* j'explique quand même pour nSam = 51 qui est multiple de nNom = 17.

Pour ecart = 0 toutes les cellules de la plage DONNEES!B3:B19 contiennent 6.

ecart =1 est impossible car si des cellules sont égales à 7 (ou 5) le total ne sera plus 102.

A+