XL 2016 Répartition équitable de binômes

halecs93 · 30 Juillet 2024

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.

job75 · 2 Août 2024

La macro avec 3 Dictionary :

VB:

Sub Tirages()
Dim tablo As Range, nNom%, delai%, dferie As Object, c As Range, dinterdit As Object
Dim d As Object, col%, 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
Set d =...

halecs93 · 1 Août 2024

Dranreb à dit:
Un exemple joint pour votre problème.

Bonjour,

J'ai modifié quelque peu les codes. En effet, lorsque je supprimais un nom en colonne G, les binômes ne se généraient pas correctement. Je le poste ici, et merci pour votre réponse d'hier.

job75 · 1 Août 2024

Bonjour halecs93, le forum,

Une solution très simple en conservant le fichier du post #1 :

VB:

Sub Tirages()
Dim tablo As Range, nNom%, col%, c As Range, nSam%, r1%, r2%, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
Application.ScreenUpdating = False
Randomize
'---RAZ---
1 For col = 3 To 25 Step 2
    Sheets("CALENDRIER").Range("A5:A35").Columns(col) = ""
Next col
'---tirages aléatoires---
For col = 2 To 24 Step 2
    For Each c In Sheets("CALENDRIER").Range("A5:A35").Columns(col).Cells
        If IsDate(c) Then
            If Weekday(c) = 7 Then
                nSam = nSam + 1
                Do
                    r1 = 1 + Int(Rnd * nNom)
                    r2 = 1 + Int(Rnd * nNom)
                    c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                    ecart = Application.Max(tablo) - Application.Min(tablo)
                Loop While r1 = r2 Or ecart > 1
            End If
        End If
Next c, col
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1
End Sub

A+

job75 · 1 Août 2024

J'ai fait plusieurs essais et il semble que la ligne :

VB:

If nSam Mod nNom = 0 And ecart Then GoTo 1

ne soit pas nécessaire : l'écart se met à zéro quand nSam est multiple de nNom.

halecs93 · 1 Août 2024

job75 à dit:

Bonjour halecs93, le forum,

Une solution très simple en conservant le fichier du post #1 :

VB:

Sub Tirages()
Dim tablo As Range, nNom%, col%, c As Range, nSam%, r1%, r2%, ecart%
Set tablo = [Tableau1] 'tableau structuré
nNom = tablo.Rows.Count
Application.ScreenUpdating = False
Randomize
'---RAZ---
1 For col = 3 To 25 Step 2
    Sheets("CALENDRIER").Range("A5:A35").Columns(col) = ""
Next col
'---tirages aléatoires---
For col = 2 To 24 Step 2
    For Each c In Sheets("CALENDRIER").Range("A5:A35").Columns(col).Cells
        If IsDate(c) Then
            If Weekday(c) = 7 Then
                nSam = nSam + 1
                Do
                    r1 = 1 + Int(Rnd * nNom)
                    r2 = 1 + Int(Rnd * nNom)
                    c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                    ecart = Application.Max(tablo) - Application.Min(tablo)
                Loop While r1 = r2 Or ecart > 1
            End If
        End If
Next c, col
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1
End Sub

A+

Yes, merci. Mais le souci, c'est que je ne veux pas qu'un nom réapparaisse avant au moins 6 samedis

Dranreb · 1 Août 2024

Je peux vous arranger ça …

halecs93 · 1 Août 2024

Dranreb à dit:
Je peux vous arranger ça …

grand merci

Dranreb · 2 Août 2024

Voyez si ça va mieux …

job75 · 2 Août 2024

Bonjour halecs93, le forum,

halecs93 à dit:
Yes, merci. Mais le souci, c'est que je ne veux pas qu'un nom réapparaisse avant au moins 6 samedis

Avec un Dictionary mémorisant les dates limites il n'y a plus de souci :

VB:

Sub Tirages()
Dim tablo As Range, nNom%, delai%, d As Object, col%, c As Range, nSam%, r1%, r2, 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
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
                    nSam = nSam + 1
                    Do
                        r1 = 1 + Int(Rnd * nNom)
                        r2 = 1 + Int(Rnd * nNom)
                        rejet = r1 = r2 Or c < d(r1) Or c < d(r2) 'cette variable fait gagner du temps
                        If Not rejet Then
                            c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                            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
    Next c, col
End With
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1 'si nécessaire...
End Sub

Je pense que vous comprendrez pourquoi la variable rejet fait gagner du temps.

A+

halecs93 · 2 Août 2024

job75 à dit:

Bonjour halecs93, le forum,

Avec un Dictionary mémorisant les dates limites il n'y a plus de souci :

VB:

Sub Tirages()
Dim tablo As Range, nNom%, delai%, d As Object, col%, c As Range, nSam%, r1%, r2, 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
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
                    nSam = nSam + 1
                    Do
                        r1 = 1 + Int(Rnd * nNom)
                        r2 = 1 + Int(Rnd * nNom)
                        rejet = r1 = r2 Or c < d(r1) Or c < d(r2) 'cette variable fait gagner du temps
                        If Not rejet Then
                            c(1, 2) = tablo(r1, 1) & vbLf & tablo(r2, 1)
                            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
    Next c, col
End With
'---écart nul---
If nSam Mod nNom = 0 And ecart Then GoTo 1 'si nécessaire...
End Sub

Je pense que vous comprendrez pourquoi la variable rejet fait gagner du temps.

A+

Bonjour et merci.

Très efficace, en effet.

J'ai "bricolé" deux codes afin d'ajouter deux contraintes supplémentaires, à savoir :

- Interdire de facto certains binômes ;
- Ne pas générer de binômes si un samedi est férié.

Je pense que ça fonctionne

Et puis, une feuille "resume".

Je mets le fichier ici.

Encore merci à tous.

job75 · 2 Août 2024

Pour éliminer les jours fériés et les binômes interdits il serait plus logique d'utiliser 2 autres Dictionary initialisés dès le début.

halecs93 · 2 Août 2024

job75 à dit:
Pour éliminer les jours fériés et les binômes interdits il serait plus logique d'utiliser 2 autres Dictionary initialisés dès le début.

....peut-être...sans doute, même... mais je ne sais pas faire

job75 · 2 Août 2024

Je vais vous les faire.

job75 · 2 Août 2024

La macro avec 3 Dictionary :

VB:

Sub Tirages()
Dim tablo As Range, nNom%, delai%, dferie As Object, c As Range, dinterdit As Object
Dim d As Object, col%, 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
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
                        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
End Sub

halecs93 · 2 Août 2024

job75 à dit:

La macro avec 3 Dictionary :

VB:

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

Merci...je regarderai cela de plus près demain

job75 · 2 Août 2024

Notez qu'avec les binômes interdits on peut avoir parfois des bouclages sans fin.

Il faudra alors en sortit par la touche <échap>.

XL 2016 Répartition équitable de binômes

XLDnaute Impliqué

Pièces jointes

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Discussions similaires