VBA Arrays - conditions et maths !!!

Bonjour à tous amis matheux.
Mon problème est assez simple

Dans l"quipe du père noel il y a :
- 16 lutins qui doivent tous travailler de manière la plus équitable possible
- Par jour arrive X demandes de cadeaux (X est un aléa de 1 à 100)
Evidemment X est un entier... on ne va pas faire des morceaux de cadeaux !

En sachant que les lutins sont rémunérés par nombre de cadeaux produits,
Le père noel, dans sa grande bonté veut répartir équitablement les cadeaux à
produire par lutins et donc leur salaire !

L'objectif : Déterminer le nombre de cadeaux journaliers qu'un lutin doit
produire.
on pourra faire un test sur 2 ou 3 jours.

Jour 1 : 5 cadeaux
Jour 2 : 15 cadeaux
Jour 3 : 30 cadeaux

Il faut avoir le nb de cadeaux à attribuer à chaque Lutin.

A la main c'est facile, mais en programmation j'ai du mal :



Voici mon début de réponse, mais je bloque au niveau des restrictions :
On doit toujours avoir AU MAXIMUM 1 et 1 seul dossier d'écart entre les
individus. Et c'est comme ça que je réfléchi dans je fais des exemples à la
main.
D'où la proposition suivante :

Si le nombre de cadeaux cumulés de la personne précédente ET de la personne
suivante est INFERIEUR à (nombre de cadeaux cumulés de la personne en cours
+1 1) ALORS on peut mettre +1.
Reste le cas du 1er bonhomme de la liste.
soit on le compare à une moyenne, soit on le compare au maximum des cumules
de la fois d'avant. (Il faudrait explorer cette notion de maximum comparé.)


Pour les plus courageux, voici mon code à corriger :

Option Base
'**************************************************************************************
' Public Vars Declaration - variables déclarées au niveau global pour accès
à toutes
' les sub routines et functions du modul
'**************************************************************************************
Dim PeopleArray(), ResultEntArray(), ResteArray(), DossiersAleaDates() As
Double
Dim ValRecherche As String
Dim LabelArray() As Variant
Dim x, y, z, i, j, xrang, irang, ireste, NumberOfDates, NumberOfPeople,
TypesDossiers, PeopleColumn, DatesColum, NumberOfResultsLines As Long
Dim Mtotal As Double
Dim DatesRange, DossiersRange, PeopleRange, CellRecherche As Range
'

Sub Result_Zone()
'Application.ScreenUpdating = False
Sheets("Data").Select ' Evite des erreur sur les formules liées aux données
de la feuille.
TypesDossiers = 3 ' Nombre de types de dossiers - à variabiliser

' Recherche de la colonne où se situe les Collaborateurs
ValRecherche = "Collaborateurs"
Set CellRecherche = Sheets("Data").Range("1:1").Find(ValRecherche,
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=True, SearchFormat:=False)
If CellRecherche Is Nothing Then
Else
PeopleColumn = CellRecherche.Column
End If

'Recherche de la colonne où se situe les Dates
ValRecherche = "Dates"
Set CellRecherche = Sheets("Data").Range("1:1").Find(ValRecherche,
lookat:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext,
MatchCase:=True, SearchFormat:=False)
If CellRecherche Is Nothing Then
Else
DatesColumn = CellRecherche.Column
End If

' utilisation de la fonction compteur CountCells que j'ai programmé
NumberOfDates = CountCells("D")
NumberOfPeople = CountCells("I")
NumberOfResultsLines = NumberOfPeople * NumberOfDates

' Redimensionnement des ARRAY/MATRICES
ReDim LabelArray(NumberOfResultsLines, TypesDossiers + 4)
ReDim PeopleArray(NumberOfPeople, TypesDossiers + 3)
ReDim ResultEntArray(NumberOfDates, TypesDossiers + 2)
ReDim ResteArray(NumberOfDates, TypesDossiers + 2)
ReDim DossiersAleaDates(NumberOfDates, TypesDossiers)

'Données des dates et nombres aléatoires dans un Array
For y = 1 To 3 ' 3=nombre de types de dossiers
For x = 1 To NumberOfDates
DossiersAleaDates(x, y) = Cells(x + 1, y + 4).Value
Next x
Next y

' Libellés de Dates ET des Noms dans un tableau VBA
Set DatesRange = Range(Cells(1, 4), Cells(NumberOfDates, 4)) 'Range("D1:D" &
NumberOfDates)
Set DossiersRange = Range(Cells(1, 5), Cells(1, 7))
Set PeopleRange = Range(Cells(1, PeopleColumn), Cells(NumberOfPeople,
PeopleColumn))


'############################################################################################
'########################### Partie calulatoire
'############################################################################################
'Libellés dans la matrice
LabelArray(1, 1) = Cells(1, 4).Value
LabelArray(1, 2) = Cells(1, PeopleColumn).Value
LabelArray(1, 3) = "P1"
LabelArray(1, 4) = "P2"
LabelArray(1, 5) = "P3"
LabelArray(1, 6) = "Total"
LabelArray(1, 7) = "Cumulé"

xrang = 1
irang = 1
Mtotal = 0

'Boucle sur les dates
For y = 2 To NumberOfDates
'Boucle sur les individus - libellés
For x = 2 To NumberOfPeople
xrang = xrang + 1 ' quand x=2 val de départ, xrang = 1+1 =2 où
xrang est le n°ligne
LabelArray(xrang, 1) = Cells(y, 4).Value ' Les dates en 1ere
colonne de matrice
LabelArray(xrang, 2) = PeopleRange.Cells(x, 1).Value ' Les noms
en 2eme colonne
PeopleArray(x - 1, 1) = PeopleRange.Cells(x, 1).Value
'
' Mtotal = PeopleArray(x - 1, 6) + Mtotal
Next x
' Debug.Print "Totaldossiers=", Mtotal
' Mtotal = Mtotal / (NumberOfPeople - 1)
' Debug.Print "Moyennedossiers", Mtotal

' Calculer une moyenne à chaque passage à une nouvelle date !!!!!!!!
'---------------------------------------------------------------------------------------------

'Formules de calcul de la partie entière et du reste
For z = 1 To 3 ' 3=nombre de types de dossiers
ireste = 1 ' on remet le compteur de reste de division à 0
ResultEntArray(y - 1, z) = Int(DossiersAleaDates(y - 1, z) /
(NumberOfPeople - 1))
ResteArray(y - 1, z) = (DossiersAleaDates(y - 1, z)) Mod
(NumberOfPeople - 1)
'Debug.Print "Reste=" & ResteArray(y - 1, z)

For j = 2 To NumberOfPeople
Mtotal = PeopleArray(j - 1, 6) + Mtotal
Next j
Mtotal = Mtotal / (NumberOfPeople - 1)

' boucle sur partie entière
For i = 2 To NumberOfPeople
irang = i + ((y - 2) * (NumberOfPeople - 1))
PeopleArray(i - 1, z + 1) = ResultEntArray(y - 1, z)

' Gerer le cas du reste
Debug.Print "date=" & y & " type=" & z & "
Moyenne=" & Mtotal, PeopleArray((i - 1), 6)
Debug.Print "date=" & y & " type=" & z & "
reste=" & ResteArray(y - 1, z) & " ireste=" & ireste

Select Case PeopleArray((i - 1), 6)
Case 0 To Mtotal
If ResteArray(y - 1, z) > 0 And
ireste <= ResteArray(y - 1, z) Then
PeopleArray(i - 1, z + 1) =
(PeopleArray(i - 1, z + 1)) + 1
ireste = ireste + 1
'Debug.Print "ireste=" & ireste
Else
End If

' condition fausse car resteArray peut SOUVENT être inférieur à Mtotal...
Case Mtotal To ResteArray(y - 1, z)
If ResteArray(y - 1, z) > 0 And
ireste <= ResteArray(y - 1, z) Then
' condition à trouver pour gerer dans le reste est > à la moyenne
If ResteArray(y - 1, z - 1) >
((NumberOfPeople - 1) / 2) Then
PeopleArray(i - 1, z + 1) =
(PeopleArray(i - 1, z + 1)) + 1
ireste = ireste + 1
Else
End If
'Debug.Print "ireste=" & ireste
Else
End If
Case Else
If PeopleArray((i - 1), 6) > ResteArray(y -
1, z) And PeopleArray((i - 1), 6) > Mtotal Then

Else
End If
End Select


' Incrémentation du total de la ligne - a variabiliser
pour le fun
PeopleArray(i - 1, 5) = PeopleArray(i - 1, 2) +
PeopleArray(i - 1, 3) + PeopleArray(i - 1, 4)
' Incrémentation du total cumulé
PeopleArray(i - 1, 6) = PeopleArray(i - 1, 6) +
PeopleArray(i - 1, z + 1) ' 5 = 1 + 3 + 1

' Les totaux dans le tableau de rendu
LabelArray(irang, z + 2) = PeopleArray(i - 1, z + 1)
LabelArray(irang, 6) = PeopleArray(i - 1, 2) +
PeopleArray(i - 1, 3) + PeopleArray(i - 1, 4)
LabelArray(irang, 7) = PeopleArray(i - 1, 6) ' 5 =
1+3+1 =Libelles + nbre dossiers + 1
Next i



'For j = 1 To ResteArray(y - 1, z)
' For i = 2 To NumberOfPeople
' If ResteArray(y - 1, z) > 0 And ireste <=
ResteArray(y - 1, z) Then
' PeopleArray(i - 1, z + 1) = (PeopleArray(i - 1, z +
1)) + 1
' ireste = ireste + 1
' Next i
'Next j


Next z

Next y
'---------------------------------------------------------------------------------------------


'Transfère les éléments de la matrice dans la feuille de calcul
Worksheets("Results").Activate
Range(Cells(1, 1), Cells(UBound(LabelArray, 1), UBound(LabelArray, 2))) =
LabelArray
Range(Cells(2, 8), Cells(UBound(ResultEntArray, 1), UBound(ResultEntArray,
2) + 5)) = ResultEntArray
Range(Cells(2, 11), Cells(UBound(ResteArray, 1), UBound(ResteArray, 2) + 8))
= ResteArray

End Sub

La fonction de décompte des cellules :
Function CountCells(columnletter As String) As Long
' Equivaut à la formule NBVAL d'excel mais
' en plus long...
' Ne sert qu'à garder toutes les infos en vba
Dim countcellsNbValeur As Long
Dim countcel As Object
CountCells = 0
columnletter = columnletter & ":" & columnletter
'Debug.Print columnletter
For Each countcel In Range(columnletter)
If countcel.Value = "" Then
Else
CountCells = CountCells + 1
End If
Next countcel
End Function

--
olivier