Défi Mathématique (en vba)

[Amandineuh]

Coucou la compagnie,

J'ai un petit casse tête chinois, pour lequel je solicite votre aide.

C'est un problème d’arrangement :
J'ai des groupes limités à 16 personnes, et qui sont constitués à partir de sous groupes de 1,2,3,4,5,6 personnes.

La question est comment parvenir à créer ces groupes le mieux possible (tendre vers la limite de 16 personnes par "super" groupes ou l'atteindre)? Ceci en macro VBA si c'est possible évidement.

J'ai joins un fichier exemple pour le support didactique,
Merkiiiiii,
Amandine.

 

[Modeste geedee]

Re : Défi Mathématique (en vba)


Bonsour®

la force brute... arrangements aleatoires

faire une copie en valeur lorsque le résultat est satisfaisant

 

[mapomme]

Re : Défi Mathématique (en vba)

Bonjour Amandineuh, Modeste geedee, à tous,

Un autre essai. Ne donne pas forcément la solution optimale mais une solution approchée; je n'ai pas du tout optimisé le code .
J'ai fait l'hypothèse que le nombre de groupes peut être inférieur à 10 (si on veut pour chaque groupe s'approcher de 16).

Le code est dans le module de code de la feuille "Feuil1":

Sub test()
Dim Neq, Poids, PoidsTotal, PoidsCourant, i
Dim MyRG As Range, compo As String

Set MyRG = Range("B" & Rows.Count).End(xlUp)
Set MyRG = Range(Range("B6"), MyRG)
MyRG.Resize(, 2).Sort key1:=Range("C6"), _
  order1:=xlDescending, Header:=xlNo
MyRG.Offset(, 2) = True
MyRG.Offset(, 3) = ""
MyRG.Offset(, 6).Resize(100, 3) = ""

PoidsTotal = Application.WorksheetFunction.Sum(MyRG.Offset(, 1))
Do While PoidsCourant < PoidsTotal
  Neq = Neq + 1
  Poids = 0: compo = ""
  For i = MyRG.Row To MyRG.Row + MyRG.Rows.Count - 1
    If Cells(i, "c") + Poids <= 16 And Cells(i, "D") Then
      Poids = Cells(i, "c") + Poids
      Cells(i, "D") = False
      Cells(i, "E") = Neq
      compo = compo & "; " & Cells(i, "B")
    End If
  Next i
  PoidsCourant = PoidsCourant + Poids
  Cells(5 + Neq, "h") = Neq
  Cells(5 + Neq, "i") = Poids
  Cells(5 + Neq, "j") = Mid(compo, 2)
Loop

MyRG.Resize(, 4).Sort key1:=Range("E6"), _
  order1:=xlAscending, Header:=xlNo

End Sub

NB: attention le fichier v1 était en calcul manuel, le v2 a été remis en automatique.

 

[mapomme]

Re : Défi Mathématique (en vba)

Bonsoir Amandineuh,

Une dernière version avec le rajout de conditions pour éviter de rentrer dans une boucle fatale sans fin avec certaines données.

 

[Amandineuh]

Re : Défi Mathématique (en vba)

Coucou les loulous,

Merci pour votre coup de main fortement apprécié

J'aurais plaisir à décortiquer vos façons de faire pour les comprendre.
En tout cas le défi est remporté avec beaucoup de facilité c'est une certitude.

Merci à vous deux,
Et grosse bise au passage

 

[Modeste geedee]

Re : Défi Mathématique (en vba)

Bonsour®

la réponse de mapomme correspond en effet au mieux à la condition :

tendre vers la limite de 16 personnes

uniquement pour le fun ...
l'optimisation serait meilleure pour un total multiple de 16 personnes (128 ou 144 au lieu de 134)
mais avec les données fournies , le résultat est optimum avec limite 15 personnes

un parametre d'ajustement serait justement de limiter/fixer le nombre de supers équipes (cas implicite de ma proposition)