XL 2016 Répartitions de valeurs en groupes homogènes.

[AZERTYBIO]

Bonjour,

Je souhaitais répartir 19 valeurs qui sont des volumes en 6 groupes équivalent (3 ou 4 valeurs par groupes) où chaque groupe à la même moyenne de volume. J'aurais besoin de faire ce travail plusieurs fois donc je souhaiterais une formule ou une aide que je puise appliquer à tous mes fichiers. (le nombre d'individus par groupe peut être variable dans chaque fichier)

En vous remerciant

 

[JHA]

Bonjour à tous,

Il y a certainement mieux à faire.

JHA

 

[job75]

Bonjour AZERTYBIO, JHA, le forum,

Voyez le fichier joint et cette macro qui réalise des tirages aléatoires :

Sub Tirages()
Dim t, ntirage&, ecart As Range, ecartmin As Range, i&
t = Timer
ntirage = 100000
Set ecart = [I22]
Set ecartmin = [E22]
ecartmin = 10 ^ 99
Application.ScreenUpdating = False
For i = 1 To ntirage
    Calculate
    If ecart < ecartmin Then Range("D2:E22") = Range("H2:I22").Value
Next i
Application.ScreenUpdating = True
MsgBox Format(ntirage, "#,##0") & " tirages en " & Format(Timer - t, "0.00 \sec"), , "Tirages"
End Sub

C'est une méthode brute de fonderie, je ne cherche pas à améliorer la rapidité.

Avec mon dernier tirage j'ai obtenu un écart de 4,27.

A+

 

[job75]

Bonjour AZERTYBIO, le forum,

Je reviens avec cette macro 3 fois plus rapide :

Sub Tirages()
Dim t, ntirage&, tablo, ub&, d As Object, ecartmin#, groupe, i&, a(), j&, r&, n%, b, ecart#, memo
t = Timer
ntirage = 100000
tablo = [A2:A20] 'à adapter
ub = UBound(tablo)
Set d = CreateObject("Scripting.Dictionary")
ecartmin = 10 ^ 99
Randomize
Application.ScreenUpdating = False
[D2].Resize(ub) = "=RAND()"
[C1:E1].Resize(ub).Sort [D1], Header:=xlYes 'tri aléatoire initial
groupe = [C2].Resize(ub)
For i = 1 To ntirage
    ReDim a(1 To ub, 1 To 1)
    d.RemoveAll 'RAZ
    For j = 1 To ub
        Do
            r = 1 + Int(Rnd * ub) 'numéro de ligne aléatoire
        Loop While a(r, 1) <> ""
        a(r, 1) = tablo(j, 1)
        n = groupe(r, 1)
        d(n) = d(n) + a(r, 1) 'somme des valeurs
    Next j
    b = d.items
    ecart = Application.Max(b) - Application.Min(b)
    If ecart < ecartmin Then ecartmin = ecart: memo = a 'mémorisation
Next i
'---restitution---
[D2].Resize(ub) = memo
[C1:E1].Resize(ub).Sort [C1], Header:=xlYes 'tri pour classer les groupes
Application.ScreenUpdating = True
MsgBox Format(ntirage, "#,##0") & " tirages en " & Format(Timer - t, "0.00 \sec"), , "Tirages"
End Sub

Le tri initial place les groupes de manière aléatoire.

Il est indispensable sinon les écarts prennent des valeurs qui se répètent périodiquement.

A+

 

[mapomme]

Bonjour @AZERTYBIO 🙂, @JHA 😉, @job75 😉,

J'avais un peu de temps à tuer donc je me suis intéressé à la chose. Je n'ai aucunement examiné vos productions. Donc ce que j'ai fait relève peut-être d'un fortuit plagiat.

Deux méthodes pour limiter l'exploration :

1. on se limite à un nombre d'itération qu'on indiquera en G5 avant de cliquer sur le bouton bleu
2. ou on fixe une durée de traitement qu'on indiquera en G12 avant de cliquer sur le bouton vert

Le bouton orange "Réinitialisation" remet à zéro les résultats. Tant qu'on ne réinitialise pas, les deux méthodes (quel que soit le nombre de fois où on les exécute) ne retiendront que les combinaisons qui améliorent l'indicateur "Ecart max. des moyenne par groupe" en I6 et ceci même si on reprend avoir refermé le classeur.

Un changement en colonne A ou bien du nombre désiré de groupes en G2 entraine une réinitialisation.

Pour les deux méthodes, la barre d'état d'Excel (en bas à gauche) indique l'avancement du traitement ainsi que le nombre de fois où une combinaison a été meilleure que les précédentes.

nota : sur ma bécane, 1 000 000 d'itérations se font en 8 s.

 

[jurassic pork]

Hello,
Il est bien gentil AZERTYBIO il nous a "balancé" un problème à résoudre et il n'est jamais revenu dans le forum depuis.
Les solutions de job75 et mapomme sont pas mal mais on n'est pas sûr d'avoir la meilleure solution car cela se base sur un mélange aléatoire des valeurs de départ en effectuant un grand nombre de tirages. Le problème c'est que le nombre de permutations possibles pour un ensemble de 19 éléments est égal à 19! = 121,645,100,408,832,000
Très très long de tout balayer. J'ai essayé de traduire le code de mapomme en python et d'utiliser des fonctions de combinaisons mais cela n'a pas l'air très simple à optimiser. Peut être faut il utiliser des fonctions de statistiques ou de probalité mais je ne connais pas ces domaines. Finalement je suis resté sur le tirage aléatoire et le python possède une fonction de mélange d'éléments de tableaux avec distribution uniforme (random.shuffle(tableau)). En fait je lance un très grand nombre d'itérations et tous les 1000000 de fois (modulo 1000000) j'affiche ce qui a été trouvé. Voici à un moment donné ce que j'ai obtenu ( écart max de 1.86) :

[(12.3786, 1), (48.8072, 1), (34.80048, 1), (31.85, 2), (55.3696, 2), (49.55808, 2), (50.752, 3), (46.78128, 3), (37.37448, 3), (80.3374, 4), (27.98432, 4), (26.9568, 4), (38.75508, 5), (39.3354, 5), (56.94624, 5), (55.13664, 6), (19.24208, 6), (60.54048, 6), (39.104, 1)]
1.8699200000000076
[135.09028, 136.77768, 134.90776, 135.27852000000001, 135.03672, 134.9192]

Ami calmant, J.P

 

[jurassic pork]

Bon j'ai posé le problème dans le forum algorithmique de developpez. Il y a un expert qui m'a répondu avec une solution à base d'arbre. Et le résultat est spectaculaire. Voici ce qui est trouvé en 6 ms :

temps écoulé : 5.91015625 ms
[(46.78128, 38.75508, 37.37448, 12.3786), (49.55808, 50.752, 34.80048), (60.54048, 55.3696, 19.24208), (27.98432, 26.9568, 80.3374), (56.94624, 39.104, 39.3354), (48.8072, 31.85, 55.13664)]
[135.28944, 135.11056, 135.15215999999998, 135.27852000000001, 135.38564, 135.79384]
ecart max. = 0.6832799999999963

A voir si cela est adaptable en VBA.
[EDIT] Dans la même discussion il y a maintenant une solution en Windev certainement plus facile à traduire en VBA que celle en python.

 

[jurassic pork]

Hello,
bon suite à l'intervention des utilisateurs du forum algorithmique de Developpez, j'ai réussi à écrire un code en python qui calcule la meilleure solution quasi instantanément . Avec 100 itérations normalement on est sûr d'avoir la meilleure solution. J'ai intégré ce code python dans un classeur LibreOffice (qui ressemble à celui de mapomme) et voici ce que cela donne :

Ami calmant, J.P

 

[jurassic pork]

Hello,
Bon finalement j'ai réussi à traduire le code python en pure VBA ( sauf les yield générateurs). Les solutions proposées précedemment dans cette discussion en VBA par job75 et mapomme ne donnaient pas la solution optimale.

Voici le code qui fonctionne :

Function TestSubset(NumberOfElements As Long, NumberOfValues As Long, MinimumElements As Long, MaximumElements As Long, RemainingGroups As Long) As Boolean
    TestSubset = ((NumberOfValues - NumberOfElements) >= (RemainingGroups * MinimumElements)) And ((NumberOfValues - NumberOfElements) <= (RemainingGroups * MaximumElements))
End Function

Function GenSubsets(Subsets As Collection, Element As Variant, GroupSum As Double) As Collection
    ' Function to generate new subsets after adding the element
    Dim NewSubset As Collection
    Dim Subset As Variant
    Set GenSubsets = New Collection
    For Each Subset In Subsets
        ' Return the subset
        GenSubsets.Add Subset
        ' Create the new subset with the new element added
        Set NewSubset = New Collection
        Dim Item As Variant
        For Each Item In Subset
            NewSubset.Add Item
        Next Item
        NewSubset.Add Element
        If SumCollection(NewSubset) <= GroupSum Then
            GenSubsets.Add NewSubset
        End If
    Next Subset
End Function

Function GenerateSubsets(Elements As Collection, GroupSum As Double) As Collection
    Dim Subsets As Collection
    Set Subsets = New Collection
    Subsets.Add New Collection ' Start with an empty subset
    Dim Element As Variant
    For Each Element In Elements
        Set Subsets = GenSubsets(Subsets, Element, GroupSum)
    Next Element
    ' Return the generator to iterate through the obtained subsets
    Set GenerateSubsets = Subsets
End Function

Sub CalculCol()
    Dim ws As Worksheet, NbIters As Long, arrVal
    Dim NumberOfGroups As Long, MinimumElements As Long, MaximumElements As Long
    Set ws = Worksheets("Répartition")
    NumberOfGroups = ws.Range("NbGroupes").Value
    MinimumElements = ws.Range("MinElem").Value
    MaximumElements = ws.Range("MaxElem").Value
    NbIters = ws.Range("NbIters").Value
    arrVal = WorksheetFunction.Transpose(ws.Range("Valeurs"))
    ws.Range("NumEssai").Value = 0
    Dim Values As Collection
    Set Values = New Collection
    Dim OriginalValues As Object
    Set OriginalValues = CreateObject("System.Collections.ArrayList")
    Dim Value As Variant
    'For Each Value In Array(56.94624, 39.104, 27.98432, 26.9568, 60.54048, 48.8072, 49.55808, 31.85, 50.752, 55.3696, _
    '                        46.78128, 34.80048, 38.75508, 55.13664, 39.3354, 37.37448, 80.3374, 19.24208, 12.3786)
     For Each Value In arrVal
        Values.Add CDbl(Value)
        OriginalValues.Add CDbl(Value)
    Next Value
    Set Values = ShuffleCollection(Values)
    'NumberOfGroups = 7
    Dim Deviation As Double
    Deviation = 0
    Dim GroupSum As Double
    GroupSum = SumCollection(Values) / NumberOfGroups
    Debug.Print GroupSum
    'MinimumElements = 2
    'MaximumElements = 3
    Randomize
    Dim MaximumDeviation As Double
    MaximumDeviation = 9999
    Dim n As Long, i As Long, cpti As Long
    Dim Numbers As Collection, GroupList As Collection
    Dim Subset As Variant, ValueInSubset As Variant
    For n = 0 To NbIters
        Deviation = 0
        ws.Range("NumEssai").Value = n
        Do While Deviation <= 10
            Set Numbers = CloneCollection(Values)
            Set GroupList = New Collection
            For i = 0 To NumberOfGroups - 2
                cpti = i
                For Each Subset In GenerateSubsets(Numbers, GroupSum + Deviation)
                    ' If the sum of the integers in the subset is equal to GroupSum plus or minus the deviation
                    If Abs(SumCollection(Subset) - GroupSum) <= Deviation Then
                        If (Subset.count >= MinimumElements) And (Subset.count <= MaximumElements) And TestSubset(Subset.count, Numbers.count, MinimumElements, MaximumElements, (NumberOfGroups - i - 1)) Then
                            ' Add the subset of numbers
                            GroupList.Add Subset
                            For Each ValueInSubset In Subset
                                RemoveFromCollection Numbers, ValueInSubset
                            Next ValueInSubset
                            Exit For
                        End If
                    End If
                Next Subset
                If GroupList.count = i Then
                    Exit For ' Exit the loop
                End If
            Next i
           
            If GroupList.count > cpti Then
             '   Debug.Print "Exit cpti"
                Exit Do ' Exit the loop
            End If
           
            Deviation = Deviation + 0.1 ' Increment the deviation for a search
        Loop
       ' Debug.Print "Fin Loop"
        GroupList.Add Numbers ' Add the last group to the list
       
        Dim SumsGroups As Collection
        Set SumsGroups = New Collection
        Dim LengthsGroups As Collection
        Set LengthsGroups = New Collection
        Dim Group As Variant
        For Each Group In GroupList
            SumsGroups.Add SumCollection(Group)
            LengthsGroups.Add Group.count
        Next Group
        Dim MaxDeviation As Double
        MaxDeviation = MaxCollection(SumsGroups) - MinCollection(SumsGroups)
        If MaxDeviation < MaximumDeviation Then
            Debug.Print "n : " & n & " -> max deviation = " & MaxDeviation
            MaximumDeviation = MaxDeviation
            i = 1
            Dim elem As Variant, subelem As Variant
            ReDim grpVal(0 To OriginalValues.count - 1) As Integer
            For Each elem In GroupList
                For Each subelem In elem
                    grpVal(OriginalValues.IndexOf(subelem, 0)) = i
                Next subelem
            i = i + 1
            Next elem
            ws.Range("Groupes").Value2 = Application.Transpose(grpVal)
        End If
        Set Values = ShuffleCollection(Values)
    Next n
End Sub

Function SumCollection(ByVal Col As Collection) As Double
    Dim Total As Double
    Total = 0
    Dim Item As Variant
    For Each Item In Col
        Total = Total + Item
    Next Item
    SumCollection = Total
End Function
Sub RemoveFromCollection(ByRef Col As Collection, Item As Variant)
    Dim i As Long
    For i = Col.count To 1 Step -1
        If Col(i) = Item Then
            Col.Remove i
        End If
    Next i
End Sub
Function ShuffleCollection(ByVal Col As Collection) As Collection
    Set ShuffleCollection = New Collection
    Randomize
    Do While Col.count > 0
        Dim randomIndex As Integer
        randomIndex = Int(Rnd() * Col.count) + 1
        ShuffleCollection.Add Col(randomIndex)
        Col.Remove randomIndex
    Loop
End Function
Function CloneCollection(ByVal Col As Collection) As Collection
    Dim elem As Variant
    Set CloneCollection = New Collection
    For Each elem In Col
        CloneCollection.Add elem
    Next elem
End Function
Function MaxCollection(ByVal Col As Collection) As Double
    Dim Max As Double
    Max = 0
    Dim Item As Variant
    For Each Item In Col
        If Item > Max Then Max = Item
    Next Item
    MaxCollection = Max
End Function
Function MinCollection(ByVal Col As Collection) As Double
    Dim Min As Double
    Min = 99999
    Dim Item As Variant
    For Each Item In Col
        If Item < Min Then Min = Item
    Next Item
    MinCollection = Min
End Function
Sub ReinitGroupes()
    Range("Groupes").Value2 = 0
    Range("NumEssai").Value = 0
End Sub

Le calcul se fait en moins de 20 secondes pour 50 itérations Max.
et voici ce que cela donne :

En général la solution optimale est trouvée en moins de 20 itérations :

n : 0 -> max deviation = 2,70295999999999
n : 6 -> max deviation = 2,56412
n : 9 -> max deviation = 0,988519999999994
n : 12 -> max deviation = 0,683279999999996
===========================================
n : 0 -> max deviation = 7,22540000000001
n : 1 -> max deviation = 3,18603999999999
n : 4 -> max deviation = 1,26723999999999
n : 6 -> max deviation = 0,757119999999986
n : 16 -> max deviation = 0,683279999999996
==========================================
n : 0 -> max deviation = 0,699399999999969
n : 2 -> max deviation = 0,683279999999996
==========================================
n : 0 -> max deviation = 4,6618
n : 1 -> max deviation = 4,27491999999998
n : 2 -> max deviation = 1,10760000000002
n : 13 -> max deviation = 0,683279999999996

Le calcul est beaucoup plus rapide en python (moins d'une seconde) par l'emploi de yield :

def gen_subsets(sous_ensembles, element,somme_groupe):
    # fonction permettant de générer les nouveaux sous-ensembles après ajout de l'élément
    # parcours des sous-ensembles (subset)
    for subset in sous_ensembles:
        # ordre de renvoyer le sous-ensemble : descente à gauche dans l'arbre binaire
        yield subset
        # création du nouveau sous-ensemble avec ajout du nouvel élément
        new_subset = tuple(subset) + (element,)
        # ordre de renvoyer le nouveau sous-ensemble  : descente à droite dans l'arbre binaire
        if sum(new_subset)<=somme_groupe:
            yield new_subset
 
 
def generateur_subsets(elements,somme_groupe):
    # permet de génèrer les sous-ensembles à partir de l'ensemble de départ
    # tri des éléments de l'ensemble de départ
    # elements.sort()
    # initialisation de la variable sous_ensembles avec un élément vide : {{}}
    sous_ensembles = iter([()])
    # parcours des éléments de la liste de départ
    for ei in elements:
        # on génère les nouveaux sous-ensembles après ajout de ei
        sous_ensembles = gen_subsets(sous_ensembles, ei, somme_groupe)
    # renvoie la générateur permettant de parcourir les sous-ensembles obtenus
    return sous_ensembles

En VBA cela n'existe pas. Il y a une tentative d'implémentation ici mais elle ne fonctionne qu'en 32 bits à cause de l'emploi de la dll msvbvm60.dll qui n'existe qu'en 32 bits.
Mais au fait çà sert à quoi yield. Ben en fait çà sert à générer des données au fur et à mesure qu'on en a besoin et pas tout générer d'abord.
Exemple (dans le lien précédent) :

Sub testNumberRange()
    Dim c As New NumberRange
    c.generatorTo 10

    Dim idx As Long: idx = 1
    Dim val

    For Each val In c
        Debug.Print val
        If idx > 100 Then Exit Sub   ' Just in case of infinite loops
        idx = idx + 1
    Next val
End Sub

Dans cet exemple c.generatorTo ne va pas générer les 10 valeurs mais il va "envoyer" la donnée au fur et à mesure dans le Each val In c
si on fait c.generatorTo 1000000 cela ne sera pas plus lent que le c.generatorTo 10
Je ne sais pas si cela est assez clair pour vous car cela n'est pas très intuitif.
Ami calmant, J.P