XL 2013 Distribution actions

[charlyrac]

Bonjour à tous,
J'ai 3 packs d'actions à distribuer auprès de 24 employés freelance qui sont chacun employé dans 5 sociétés, les packs sont de 900 actions, 1000 actions et 2000 actions, je dois les répartir suivant des critères, j'aurais donc pour l'employé E1 les cellules B5/B6/B7/B8/B9 remplies avec les packs suivant mes critères dans les 5 sociétés et ainsi de suite pour les 24 employés. Je dois également respecter le fait qu'aucun ensemble de cellules de chaque employé ne soit identique à un autre employé, ni même identique à lui-même les autres années. Ce qui est le cas pour l'année 1 déjà remplie TOUT EN RESPECTANT LE NOMBRE ET LA VALEUR DES PACKS PAR Stés.

On ne devra donc pas trouver non plus pour année2 et année3 un ensemble de cellules identiques aux années précédentes tout en respectant encore le nombre et la valeur des packs qui ont été définies par Stés l'année 1 LA QUESTION EST PEUT-ON FAIRE UN AUTOMATISME POUR ANNEE2 ET ANNEE3 ?

 

[CISCO]

Bonsoir

On ne peut pas appliquer tout simplement l'ensemble de l'employé Ex de l'année 1 à un autre employé Ey pour l'année 2 ?

@ plus

 

[charlyrac]

Bonjour CISCO,
alors non car aucun ensemble de cellules de chaque employé ne doit être identique à un autre employé, ni même identique à lui-même les autres années. :-(

 

[job75]

Bonsoir charlyrac, CISCO,

Voyez le fichier joint et cette macro affectée au bouton :

Sub Tirage()
Dim tableau As Range, d As Object, n%, tablo As Range, i%, j%, col%, x$, y$
Set tableau = [B5:Y9,B13:Y17,B21:Y25]
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules NB.SI
Randomize
For n = 1 To 3
    Set tablo = tableau.Areas(n)
1   tablo.ClearContents 'RAZ
    d.RemoveAll
    For i = 1 To 5
        '---placement aléatoire des 1000---
        For j = 1 To tablo(i, 30)
2           col = Application.RandBetween(1, 24)
            If tablo(i, col) = "" Then tablo(i, col) = 1000 Else GoTo 2
        Next j
        '---placement aléatoire des 900---
        For j = 1 To tablo(i, 31)
3           col = Application.RandBetween(1, 24)
            If tablo(i, col) = "" Then tablo(i, col) = 900 Else GoTo 3
        Next j
        '---placement aléatoire des 2000---
        For j = 1 To tablo(i, 32)
4           col = Application.RandBetween(1, 24)
            If tablo(i, col) = "" Then tablo(i, col) = 2000 Else GoTo 4
    Next j, i
    '---évite les doublons de colonnes---
    For col = 1 To 24
        x = tablo(1, col) & tablo(2, col) & tablo(3, col) & tablo(4, col) & tablo(5, col)
        If d.exists(x) Then GoTo 1 Else d(x) = ""
        If n > 1 Then
            y = tableau.Areas(n - 1)(1, col) & tableau.Areas(n - 1)(2, col) & tableau.Areas(n - 1)(3, col) & tableau.Areas(n - 1)(4, col) & tableau.Areas(n - 1)(5, col)
            If x = y Then GoTo 1
        End If
        If n = 3 Then
            y = tableau.Areas(1)(1, col) & tableau.Areas(1)(2, col) & tableau.Areas(1)(3, col) & tableau.Areas(1)(4, col) & tableau.Areas(1)(5, col)
            If x = y Then GoTo 1
        End If
    Next col
Next n
Application.Calculation = xlCalculationAutomatic
End Sub

 

[charlyrac]

Bonsoir job75, et merci pour ce travail de pro, c'est exactement ce que je cherchai à faire, merci beaucoup

 

[charlyrac]

Bonjour JOB75, ayant de nombreuses distributions à faire de ce type avec des packs de valeurs différentes, j'ai testé ce matin avec d'autres valeurs et il est apparu des doublons lorsque je mets des valeurs différentes dans les packs définis. Peut-on y remédier?

 

[job75]

Je pense que le code pour éviter les doublons n'allait pas, voyez si ce fichier (2) convient :

Sub Tirage()
Dim tableau As Range, d As Object, n%, tablo As Range, i%, j%, k%, col%, flag As Boolean, x$, y$
Set tableau = [B5:Y9,B13:Y17,B21:Y25]
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules NB.SI
Randomize
For n = 1 To 3
    Set tablo = tableau.Areas(n)
1   tablo.ClearContents 'RAZ
    d.RemoveAll
    For i = 1 To 5
        '---placement aléatoire des 1000, 900, 2000---
        For j = 30 To 32
            For k = 1 To tablo(i, j)
2               col = Application.RandBetween(1, 24)
                If tablo(i, col) = "" Then tablo(i, col) = tablo(0, j) Else GoTo 2
    Next k, j, i
    '---évite les doublons de colonnes---
    For col = 1 To 24
        flag = False
        x = tablo(1, col) & tablo(2, col) & tablo(3, col) & tablo(4, col) & tablo(5, col)
        If d.exists(x) Then flag = True: Exit For
        d(x) = ""
        If n > 1 Then
            y = tableau.Areas(n - 1)(1, col) & tableau.Areas(n - 1)(2, col) & tableau.Areas(n - 1)(3, col) & tableau.Areas(n - 1)(4, col) & tableau.Areas(n - 1)(5, col)
            If x = y Then flag = True: Exit For
        End If
        If n = 3 Then
            y = tableau.Areas(1)(1, col) & tableau.Areas(1)(2, col) & tableau.Areas(1)(3, col) & tableau.Areas(1)(4, col) & tableau.Areas(1)(5, col)
            If x = y Then flag = True: Exit For
        End If
    Next col
    If flag Then GoTo 1
Next n
Application.Calculation = xlCalculationAutomatic
End Sub

Quelques explications :

- on fait 3 boucles (n), une pour chaque tableau (tablo)

- pour chaque tableau on place sur chaque ligne aléatoirement les valeurs requises 1000 900 2000

- on élimine les colonnes qui sont des doublons grâce au Dictionary et en comparant d'un tableau à l'autre.

 

[charlyrac]

Par exemple

 

[job75]

Il faudrait que vous joigniez votre fichier en indiquant où se trouvent les doublons de colonnes.

Attention, entre 2 tableaux il peut y avoir des doublons, les seuls qui sont éliminés sont ceux qui se trouvent sur une même colonne.

 

[charlyrac]

j'ai testé le deuxième fichier et de nombreux doublons y figurent lorsque je refais un tirage avec des packs différents

 

[charlyrac]

Ah d'accord alors effectivement il ne faudrait aucun doublon et même entre les trois tableaux

 

[job75]

effectivement il ne faudrait aucun doublon et même entre les trois tableaux

Alors avec ce fichier (3) chaque colonne d'un tableau est unique sur l'ensemble des 3 :

Sub Tirage()
Dim tableau As Range, d As Object, n%, tablo As Range, i%, j%, k%, col%, flag As Boolean, x$
Set tableau = [B5:Y9,B13:Y17,B21:Y25]
Set d = CreateObject("Scripting.Dictionary")
Randomize
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules NB.SI
For n = 1 To 3
    Set tablo = tableau.Areas(n)
1   tablo.ClearContents 'RAZ
    '---placement aléatoire des 1000, 900, 2000---
    For i = 1 To 5
        For j = 30 To 32
            For k = 1 To tablo(i, j)
2               col = Application.RandBetween(1, 24)
                If tablo(i, col) = "" Then tablo(i, col) = tablo(0, j) Else GoTo 2
    Next k, j, i
    '---évite les doublons de colonnes---
    For col = 1 To 24
        flag = False
        x = tablo(1, col) & tablo(2, col) & tablo(3, col) & tablo(4, col) & tablo(5, col)
        If d.exists(x) Then
            For j = 1 To 24
                x = tablo(1, j) & tablo(2, j) & tablo(3, j) & tablo(4, j) & tablo(5, j)
                If d.exists(x) Then d.Remove x 'retire chaque item du tableau en cours
            Next j
            flag = True
            Exit For
        End If
        d(x) = ""
    Next col
    If flag Then GoTo 1
Next n
Application.Calculation = xlCalculationAutomatic
End Sub

 

[charlyrac]

merci JOB75 cependant je crois que lorsque les packs définis sont similaires cela s'avère compliqué de ne pas avoir de doublons et même des triples...?

 

[job75]

La solution de mon fichier (3) ne va pas : le Dictionary contient moins de 72 items (testez d.Count).

J'ai corrigé la macro, j'arrive alors à créer les 2 premiers tableaux mais le 3ème boucle sans fin.

Je n'ai plus de solution, il faudra vous contenter de la solution du fichier (2) post #7.

 

[job75]

Ce n'est pas fini pour les colonnes uniques

Le nombre de tirages acceptables dépend des nombres de 1000, 900, 2000 sur chaque ligne.

On peut penser qu'on maximalise les chances de réussite si ces 3 nombres sont tous égaux à 8.

Testez ce fichier (4) et la macro :

Sub Tirage()
Dim tableau As Range, d As Object, n%, ntirage&, tablo As Range, i%, j%, k%, col%, flag As Boolean, x$
Set tableau = [B5:Y9,B13:Y17,B21:Y25]
Set d = CreateObject("Scripting.Dictionary")
Randomize
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules NB.SI
For n = 1 To 3
    ntirage = 0
    Set tablo = tableau.Areas(n)
1   tablo.ClearContents 'RAZ
    If ntirage = 1000 Then MsgBox "1000 tirages sans résultat pour le tableau n° " & n: GoTo 3
    ntirage = ntirage + 1
    '---placement aléatoire des 1000, 900, 2000---
    For i = 1 To 5
        For j = 30 To 32
            For k = 1 To tablo(i, j)
2               col = Application.RandBetween(1, 24)
                If tablo(i, col) = "" Then tablo(i, col) = tablo(0, j) Else GoTo 2
    Next k, j, i
    '---évite les doublons de colonnes---
    flag = False
    For col = 1 To 24
        x = tablo(1, col) & tablo(2, col) & tablo(3, col) & tablo(4, col) & tablo(5, col)
        If d.exists(x) Then
            For j = 1 To col - 1
                x = tablo(1, j) & tablo(2, j) & tablo(3, j) & tablo(4, j) & tablo(5, j)
                d.Remove x 'retire chaque item du tableau en cours
            Next j
            flag = True
            Exit For
        End If
        d(x) = ""
    Next col
    If flag Then GoTo 1
Next n
3 Application.Calculation = xlCalculationAutomatic
End Sub