XL 2010 Répartition dans des groupes sous contraintes

[Markcaven]

Bonjour,
Existerait il un code vba permettant de répartir des employés équitablement, pas plus de 12 personnes par groupe, en évitant au maximum que 2 personnes d un meme service ne puisse appartenir au même groupe. Les En tete de colonne sont : nom, prenom, service et groupe. Le nombre d employés sera d une centaine environ. Merci d'avance pour ce qu il vous sera possible de me proposer.

 

[Dranreb]

Bonjour.
Ça reprendra des pièces de ce classeur, assurément.

 

[Dranreb]

Voici un premier jet inspiré du tirage par poules simultanées.
Mais il n'essaie pas pour l'instant de produire plus de groupes mais moins remplis si c'était le seul moyen de permettre des services différents dans chacun. Mais s'il y a largement plus de 12 services de très peu d'effectifs ça ne devrait pas poser de problème.

 

[Markcaven]

Fichiers répondant parfaitement à la demande et d'une très grande richesse. Merci et Bravo !

 

[job75]

Bonsoir Markcaven, Bernard,

Une solution simple avec des tirages aléatoires :

Sub Tirages()
Dim Ngroupe%, tablo, ub%, d As Object, ecart%, tirage&, i%, x$, memo, e%
Ngroupe = [F2] 'à adapter
tablo = [A1].CurrentRegion
ub = UBound(tablo)
Set d = CreateObject("Scripting.Dictionary")
Randomize
Application.ScreenUpdating = False
ecart = 100
For tirage = 1 To 2000
    d.RemoveAll 'RAZ
    For i = 2 To ub
        Do
            tablo(i, 4) = Application.RandBetween(1, Ngroupe)
            x = tablo(i, 3) & tablo(i, 4)
        Loop While d.exists(x)
        d(x) = ""
    Next i
    memo = Range("D1").Resize(ub)
    Range("D1").Resize(ub) = Application.Index(tablo, , 4)
    e = Application.Max(Range("H2:AA2")) - Application.Min(Range("H2:AA2"))
    If e < ecart Then ecart = e Else Range("D1").Resize(ub) = memo
Next tirage
End Sub

Les tirages visent à réduire les écarts entre les groupes.

A+

 

[job75]

Bonjour le forum,

Avec 2 Dictionary c'est plus rapide :

Sub Tirages()
Dim t, Ngroupe%, Ntirage&, tablo, ub%, d As Object, dd As Object, ecart%, tirage&, i%, x$, y$, a, e%, memo, n
t = Timer
Ngroupe = [F2] 'à adapter
Ntirage = 2000 'à adapter
tablo = [A1].CurrentRegion
ub = UBound(tablo)
Set d = CreateObject("Scripting.Dictionary")
Set dd = CreateObject("Scripting.Dictionary")
ecart = 100
Randomize
For tirage = 1 To Ntirage
    d.RemoveAll 'RAZ
    dd.RemoveAll 'RAZ
    For i = 2 To ub
        Do
            tablo(i, 4) = Application.RandBetween(1, Ngroupe)
            x = tablo(i, 4)
            y = tablo(i, 3) & x
        Loop While d.exists(y)
        d(y) = ""
        dd(x) = dd(x) + 1
    Next i
    a = dd.items
    e = Application.Max(a) - Application.Min(a)
    If e < ecart Then
        ecart = e
        memo = Application.Index(tablo, , 4)
        n = n + 1
    End If
Next tirage
Range("D1").Resize(ub) = memo
MsgBox Ntirage & " tirages en " & Format(Timer - t, "0.00 \sec") & vbLf & vbLf & "Ecart " & ecart & " avec " & n & " améliorations"
End Sub

Une petite explication si nécessaire : les doublons sur SERVICE & GROUPE sont évités donc le nombre de groupes ne doit pas être inférieur au nombre d'employés de chaque service.

A+

 

[Markcaven]

C'est parfaitement fonctionnel !!!! Un grand merci pour votre précieuse aide.

 

[Dranreb]

Bonjour.
Je me suis aperçu que mon système de tirage n'est pas utilisable avec les données de @job75.
J'ai donc adopté une autre technique (qui ressemble d'ailleurs un peu à la sienne probablement).
Attention: une sélection d'un intitulé place la colonne devant, classe la liste dessus et ajoute une mise en forme conditionnelle pour bien mettre en évidence les paquets.

 

[mapomme]

Bonjour à tous ,

Une autre manière de procéder relativement rapide et sans dictionary.
La philosophie n'est pas la même :

• on fixe le nombre de groupe de 1 à n
• et on remplit les groupes de façon équitable

On évite le biais de la multiplication des groupes si par exemple un service a sensiblement plus de membres qu'un autres.

Ce cas est relativement fréquent. On organise un séminaire. On fait des groupes de travail avec un animateur. Le nombre d'animateurs est souvent limité ou on ne dispose que physiquement d'un nombre limité de salles de travail ou tout simplement on ne veut pas multiplier indument le nombres de groupes de travail (que les restitutions sont longues en séance plénière ! ). Dans ce cas, le nombre de groupes est égal au nombre d'animateurs ou de salles ou bien égal à un nombre de groupes fixé à l'avance.

• Dans la cellule G1, saisir le nombre de groupes à former
• Cliquer sur le bouton "Tirage"
• Il n'y a pas de condition sur le nombre de groupe si ce n'est qu'il doit être supérieur à 0
• Le nombre de membres de n'importe quel groupe est soit n soit n+1. Un groupe n'a que deux valeurs possibles pour son effectif.

edit : version v2

Le code est dans module1 :

Sub Groupes()
Dim t, nbg#, i&, n&, k&, aux
   On Error GoTo FIN:
   Application.ScreenUpdating = False
   With Sheets("Feuil1")
      .Select
      If [g1] = "" Then Exit Sub Else nbg = [g1]
      If [e1] = "TempAuxE" Then [e1].EntireColumn.Delete
      Columns("e:e").Insert: [e1] = "TempAuxE"
      If .FilterMode Then .ShowAllData
      t = [a1].CurrentRegion
      Randomize: For i = 2 To UBound(t): t(i, 5) = Rnd: Next
      [a1].Resize(UBound(t), UBound(t, 2)) = t
      [a1].CurrentRegion.Sort key1:=[e1], order1:=xlAscending, MatchCase:=False, Header:=xlYes
      [a1].CurrentRegion.Sort key1:=[c1], order1:=xlAscending, MatchCase:=False, Header:=xlYes
      [e2].Resize(UBound(t) - 1).FormulaLocal = "=SI(C2<>C1;ALEA();E1)"
      [a1].CurrentRegion.Sort key1:=[e1], order1:=xlAscending, MatchCase:=False, Header:=xlYes
      t = [a1].CurrentRegion: n = 1 + Int(Rnd * nbg)
      For i = 2 To UBound(t)
         n = n + 1: If n = nbg + 1 Then n = 1
         t(i, 4) = n
      Next i
      ReDim r(1 To nbg)
      For i = 1 To nbg: r(i) = i: Next
      For i = 1 To nbg: k = 1 + Int(Rnd * nbg): aux = r(i): r(i) = r(k): r(k) = aux: Next i
      For i = 2 To UBound(t): t(i, 4) = r(t(i, 4)): Next
      [a1].Resize(UBound(t), UBound(t, 2)) = t
      [a1].CurrentRegion.Sort key1:=[c1], order1:=xlAscending, MatchCase:=False, Header:=xlYes, _
         key2:=[d1], order2:=xlAscending
FIN:
      If [e1] = "TempAuxE" Then [e1].EntireColumn.Delete
   End With
End Sub

 

[Dranreb]

Bonjour.
Nouvelle version parce qu'une instruction Randomize avait été oubliée et pour une amélioration: au lieu de supprimer les groupes trop garnis je garnis carrément chaque fois ceux qui le sont le moins.

 

[job75]

Bonjour le forum,

Je reviens pour un complément.

Si l'on veut pouvoir créer des groupes en nombre inférieur aux nombres de membres des services il faut accepter qu'il y ait des doublons sur SERVICE & GROUPE.

On utilisera alors cette macro avec 3 Dictionary :

Sub Tirages()
Dim t, Ngroupe%, Ntirage&, tablo, ub%, dx As Object, dy As Object, dz As Object
Dim ecart%, tirage&, i%, x$, test As Boolean, y$, z$, a, e%, memo, n
t = Timer
Ngroupe = [F2] 'à adapter
Ntirage = 2000 'à adapter
tablo = [A1].CurrentRegion
ub = UBound(tablo)
Set dx = CreateObject("Scripting.Dictionary")
Set dy = CreateObject("Scripting.Dictionary")
Set dz = CreateObject("Scripting.Dictionary")
ecart = 100
Randomize
For tirage = 1 To Ntirage
    dx.RemoveAll 'RAZ
    dy.RemoveAll 'RAZ
    dz.RemoveAll 'RAZ
    For i = 2 To ub
        x = tablo(i, 3)
        test = dx(x) < Ngroupe
        Do
            tablo(i, 4) = 1 + Int(Ngroupe * Rnd) 'aléatoire
            y = tablo(i, 4)
            z = x & y
        Loop While dz.exists(z) And test
        dx(x) = dx(x) + 1
        dy(y) = dy(y) + 1
        dz(z) = ""
    Next i
    a = dy.items
    e = Application.Max(a) - Application.Min(a)
    If e < ecart Then
        ecart = e
        memo = Application.Index(tablo, , 4)
        n = n + 1
    End If
Next tirage
[D1].Resize(ub) = memo 'restitution
MsgBox Ntirage & " tirages en " & Format(Timer - t, "0.00 \sec") & vbLf & vbLf & "Ecart " & ecart & " avec " & n & " améliorations"
End Sub

A+