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
'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))
'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
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Olivier B
En fait c'est bon, j'ai résolu ma question tout seul... J'avais foné tête baissé sur quelque chose de super compliquer avec des moyennes etc...
Or il ne suffit ni plus ni moins que calculer le minimum du cumul des dossiers traités par personne pour attribue le reste par tranche de 1. C'est tout.
Merci quand même à ceux qui on essayé.
-- olivier
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 1 '************************************************************************************** ' Public Vars Declaration - variables déclarées au niveau global pour accès à toutes ' les sub routines et functions du module '************************************************************************************** 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:úlse) 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:úlse) 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
'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))
'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
En fait c'est bon, j'ai résolu ma question tout seul...
J'avais foné tête baissé sur quelque chose de super compliquer avec des
moyennes etc...
Or il ne suffit ni plus ni moins que calculer le minimum du cumul des
dossiers traités par personne pour attribue le reste par tranche de 1.
C'est tout.
Merci quand même à ceux qui on essayé.
--
olivier
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 1
'**************************************************************************************
' Public Vars Declaration - variables déclarées au niveau global pour accès
à toutes
' les sub routines et functions du module
'**************************************************************************************
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:úlse)
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:úlse)
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
'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))
'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
En fait c'est bon, j'ai résolu ma question tout seul... J'avais foné tête baissé sur quelque chose de super compliquer avec des moyennes etc...
Or il ne suffit ni plus ni moins que calculer le minimum du cumul des dossiers traités par personne pour attribue le reste par tranche de 1. C'est tout.
Merci quand même à ceux qui on essayé.
-- olivier
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 1 '************************************************************************************** ' Public Vars Declaration - variables déclarées au niveau global pour accès à toutes ' les sub routines et functions du module '************************************************************************************** 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:úlse) 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:úlse) 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
'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))
'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