Répartition entre agents

**JofK1** · 19/11/2014, 20h30

Bonsoir à tous,

Je viens vers vous puisque mes compétences en Excel/VBA ont été dépassées.

Dans l'absolue, j'aimerais répartir les nonbres de la colonne B entre les 9 différents agents de façon équilibré. la somme de la colonne B étant 3 074 532,47 chaque agents devraient avoir une somme proche de 341 614,7. bien entendu chaque nombre ne peuevnt être utilisé qu'une seule fois.

j'espère que mon explication est assez claire

merci pour votre aide et pour votre temps

**pgz** · 19/11/2014, 23h21

Bonsoir.

Le pb m'a intéressé. Je te propose une procédure.
Pour la faire fonctionner,

il faut nommer la liste des valeurs à répartir, j'ai nommé cette plage "nmVal", dans ton exemple B5:B3222
il faut nommer le tableau des agents sans la ligne de titre et avec une ligne supplémentaire pour afficher les totaux, j'ai nommé cette plage "nmAgents", dans ton exemple E5:M3223

Le code

trie d'abord les valeurs à répartir
puis fait une première répartition en zigzag.
puis tant qu'on trouve une valeur pour réduire l'écart entre total min et total max, on enlève cette valeur à l'agent du max pour la mettre à l'agent du min.

Un coefficient est à optimiser, voir dans le code : entre 0,5 <= Coef < 1.
A 0,5 le code est rapide. Dans ton exemple, l'écart max final est 0,48. Près de 1, le code est beaucoup plus lent. Avec 0,99 on a un écart final de 0,04.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
Sub subRepart()
 
Dim oRng As Excel.Range
Dim vVal As Variant, lVal As Long
Dim vAgents As Variant, lAg As Long, jAg As Integer, jMin As Integer, jMax As Integer
Dim lNbVal As Long, iNbAgents As Integer
Dim jInit As Integer
Dim dblDelta As Double
 
Set oRng = ThisWorkbook.Names("nmVal").RefersToRange
oRng.Sort oRng(1, 1), xlDescending
vVal = oRng.Value
 
Set oRng = ThisWorkbook.Names("nmAgents").RefersToRange
vAgents = oRng.Value
 
lNbVal = UBound(vVal, 1)
iNbAgents = UBound(vAgents, 2)
If lNbVal <> UBound(vAgents, 1) - 1 Then GoTo etqErr1
 
'mettre tab agents à zéro
For lAg = 1 To UBound(vAgents, 1)
    For jAg = 1 To iNbAgents
        vAgents(lAg, jAg) = 0
    Next jAg
Next lAg
 
'répartition initiale et calcul des sommes
jInit = 0
For lVal = 1 To UBound(vVal, 1)
    jInit = IIf(jInit = 2 * iNbAgents, 1, jInit + 1)
    jAg = IIf(jInit <= iNbAgents, jInit, 2 * iNbAgents - jInit + 1)
    vAgents(lVal, jAg) = vVal(lVal, 1)
    vAgents(lNbVal + 1, jAg) = vAgents(lNbVal + 1, jAg) + vVal(lVal, 1)
Next lVal
 
Do
    'rechercher les totaux Min et Max, et calculer la différence
    jMin = 1
    jMax = 1
 
    For jAg = 2 To UBound(vAgents, 2)
        If vAgents(lNbVal + 1, jAg) < vAgents(lNbVal + 1, jMin) Then jMin = jAg
        If vAgents(lNbVal + 1, jAg) > vAgents(lNbVal + 1, jMax) Then jMax = jAg
    Next jAg
 
    dblDelta = vAgents(lNbVal + 1, jMax) - vAgents(lNbVal + 1, jMin)
 
    'rechercher le plus grand montant de Max à basculer vers min pour équilibrer le couple
    For lVal = 1 To lNbVal
        If (vAgents(lVal, jMax) > 0) And (vAgents(lVal, jMax) <= dblDelta * 0.5) Then Exit For 'ici le coefficient à régler = 0,5
    Next lVal
 
    'enlever la valeur à max pour la mettre à min
    If lVal <= lNbVal Then
        vAgents(lVal, jMin) = vAgents(lVal, jMax)
        vAgents(lVal, jMax) = 0
        vAgents(lNbVal + 1, jMin) = vAgents(lNbVal + 1, jMin) + vAgents(lVal, jMin)
        vAgents(lNbVal + 1, jMax) = vAgents(lNbVal + 1, jMax) - vAgents(lVal, jMin)
    Else
        'on n'a pas trouvé de valeur à basculer, on arrête
        Exit Do
    End If
 
Loop
 
oRng.Value = vAgents
 
Set oRng = ThisWorkbook.Names("nmVal").RefersToRange
oRng.Value = vVal
 
Set oRng = Nothing: vAgents = Null: vVal = Null
 
etqSortie:
    Exit Sub
 
etqErr1:
    MsgBox "Les plages des noms définis ""nmVal"" et ""nmAgents"" ne sont pas correctes."
    GoTo etqSortie
 
End Sub