XL 2016 Répartir dans des Groupes d'Effectifs Aléatoires ... mais pas trop

crocrocro · 26 Août 2024

Bonjour le forum,

je bute pour trouver le code me permettant d'effectuer une répartition en groupes d'effectifs plus ou moins proches.

Dans le fichier joint, il s'agit de répartir les lignes du tableau (feuille Données) en n groupes (n donné en paramètre) de plus ou moins le même effectif,
en fonction d'un paramètre d'hétérogénéité situé dans un intervalle de 1 (effectif souhaité identique pour tous les groupes) à 10 (maximum d'hétérogénéité dans les effectifs)
Par exemple avec un tableau de 100 lignes (c'est le cas du fichier en pj), à répartir en 4 groupes :
Paramètre d 'hétérogénéité = 1 : 25 - 25 - 25 - 25,
Paramètre d 'hétérogénéité = 2 : 26 - 26 - 24 - 24,
Paramètre d 'hétérogénéité = 10 : 29 - 27 - 22 - 22.

Les contraintes :
- Il ne faut pas toucher au Tableau (Tri, Filtre ...), seulement affecter les n° de groupes.
- Utiliser les paramètres du fichier et le faire uniquement par code VBA (en adaptant la macro ci-dessous)
- Les n° de Groupes doivent être attribués aléatoirement aux lignes du tableau de la feuille Données. Il ne faut pas (pour reprendre l'exemple ci-dessus), attribuer 1 aux 29 premières lignes, 2 aux 27 suivantes, 3 aux 22 suivantes et 22 aux 22 dernières.

Le code de la macro lancée par le bouton N° de Groupe Aléatoire

VB:

Option Explicit
Const F_DONNEES = "Données"

Sub GroupesAleatoires()
Dim CellGroupe As Range
Dim NbAleatoire
Dim Coeff
Dim i As Integer, j As Integer

    For i = 1 To 2
        If i = 1 Then
            ' groupes souhaités d'effectif identique
            ActiveSheet.Range("NIV_HETERO") = 1
        Else
            ' groupes souhaités avec un maximum d'hétérogénéité dans les effectifs
            ActiveSheet.Range("NIV_HETERO") = 10
        End If
        ActiveSheet.Range("NO_TEST").Offset(0, i) = ActiveSheet.Range("NIV_HETERO").Value
        '10 lignes de test de 1 à 10
        For j = 1 To 10 '10
            ' niveau d'hétérogénéité vaut de 1 à 10 -> Coeff = 1, 10, 100 ...
            Coeff = Application.Power(10, ActiveSheet.Range("NIV_HETERO") - 1)
            For Each CellGroupe In Sheets(F_DONNEES).Range("TabDonnées[Groupe]")
                Randomize
                ' Quand le Coeff vaut 1 (groupes souhaités d'effectif identique),
                '  on retrouve la formule classique pour générer un nombre aléatoire de 1 à n : "Int(n * Rnd) + 1"
                ' Quand le Coeff vaut 10 (groupes groupes souhaités avec un maximum d'hétérogénéité dans les effectifs),
                '     pas de différence avec la formule standard !!!
               NbAleatoire = Int(ActiveSheet.Range("NB_MAX") * Coeff * Rnd) + Coeff
                NbAleatoire = Int(NbAleatoire / Coeff)
                CellGroupe.Value = NbAleatoire
            Next CellGroupe
            ' L'écart (cellule MOYENNE_ECARTS en O16) est une bonne estimation de l'hétérogénéité des Groupes
            ' on affecte l'écart sur la ligne du n° de test en cours
            '   - en colonne H pour le Niveau d'hétérogénéité 1 (groupes souhaités d'effectif identique)
            '   - en colonne I pour le Niveau d'hétérogénéité 10  (groupes souhaités avec un maximum d'hétérogénéité dans les effectifs)
            ActiveSheet.Range("NO_TEST").Offset(j, i) = ActiveSheet.Range("MOYENNE_ECARTS").Value
        Next j
    Next i
   
End Sub

Merci d'avance

crocrocro · 27 Août 2024

En pj, le fichier avec la solution évoquée dans le post précédent dont voici le code

VB:

Option Explicit
Const F_DONNEES = "Données"
Const F_CALCUL = "Calcul"

Sub GroupesAleatoires()
Dim i As Integer, j As Integer, plus As Integer, moins As Integer
Dim Moyenne
Dim Tranche
Dim EcartBSup
Dim EffectifGroupe As Integer
Dim EcartAlea
Dim Signe As Integer
Dim EffectifRestant As Integer, NbRestant As Integer

    '--------
    ' Etape 1
    '--------
    ' On attribue Un effectif à chaque Groupe en fonction :
    ' - du nombre de Groupes
    ' - du niveau d'hétérogénéité souhaité
    '   - de 0 (Effectif identique pour tous les Groupes)   -> Effectif = Moyenne
    '     à 10 (Maximum d'hétérogénéité)                    -> Effectif avec un...

crocrocro · 26 Août 2024

J'ai une bonne piste, grâce à job75 pour sa solution au fil Nombre aléatoire
- Générer un nombre aléatoire entre 1 et (5 + niveau d'hétérogénéité (qui est de 1 à 10)). A Pondérer selon l'effectif total.
A faire 2 fois pour chaque groupe, donc 8 fois si 4 groupes.
- Pour chaque Groupe l'effectif devient (pour un effectif total = 100) ,
(100 / 4) + Aléatoire1 - Aléatoire2
l'écart par rapport à la moyenne sera d'autant plus grand que le niveau d'hétérogénéité l'est.
- Créer un tableau de, 100 éléments ici avec, par exemple si on a trouvé 20 pour le 1er groupe, 25 pour le 2ème, 27 pour le 3ème et 28 pour le 4ème,
on aura 1 pour les 20 premiers éléments, 2pour les 25 suivants ...
- Tri du tableau de manière aléatoire (merci job75)
- Affectation des Groupes dans le Tableau de la feuille Données avec les Groupes du tableau précédent trié aléatoirement

Je testerai et ferai un retour ici.

crocrocro · 27 Août 2024

En pj, le fichier avec la solution évoquée dans le post précédent dont voici le code

VB:

Option Explicit
Const F_DONNEES = "Données"
Const F_CALCUL = "Calcul"

Sub GroupesAleatoires()
Dim i As Integer, j As Integer, plus As Integer, moins As Integer
Dim Moyenne
Dim Tranche
Dim EcartBSup
Dim EffectifGroupe As Integer
Dim EcartAlea
Dim Signe As Integer
Dim EffectifRestant As Integer, NbRestant As Integer

    '--------
    ' Etape 1
    '--------
    ' On attribue Un effectif à chaque Groupe en fonction :
    ' - du nombre de Groupes
    ' - du niveau d'hétérogénéité souhaité
    '   - de 0 (Effectif identique pour tous les Groupes)   -> Effectif = Moyenne
    '     à 10 (Maximum d'hétérogénéité)                    -> Effectif avec un écart à la moyenne proportionnel au niveau d'hétérogénéité
    ' Exemple Effectif Total 100 à répartir en 4 Groupes -> Moyenne 25
    ' Tranche d'écart (T.E.) = Moyenne / 10 = 25 / 10 = 2.5
    ' Ecart Borne Sup.  = Moyenne - (T.E.) x (H10 - H) arrondi aun nombre supérieur
    '    soit avec l'exemple en cours :
    ' Niv. Hétéro  0    =    25   -  2.5   x (10 - 0)  = 25 - 25   =  0      0
    ' Niv. Hétéro  1    =    25   -  2.5   x (10 - 1)  = 25 - 22.5 =  2.5    3
    ' Niv. Hétéro  2    =    25   -  2.5   x (10 - 2)  = 25 - 20   =  5      5
    ' Niv. Hétéro  8    =    25   -  2.5   x (10 - 8)  = 25 -  5   = 20     20
    ' Niv. Hétéro  9    =    25   -  2.5   x (10 - 9)  = 25 -  2.5 = 22.5   23
    ' Niv. Hétéro 10    =    25   -  2.5   x (10 -10)  = 25 -  0   = 25     25
    '  -> Effectif Calculé pour le Groupe Courant = Moyenne + ou - Random de 0 à Ecart Borne Sup.
    ' en + ou - selon un Random
    ActiveSheet.Range("TabEffectifAleatoire[Effectif Aléatoire]").ClearContents
    EffectifRestant = ActiveSheet.Range("EFFECTIF_TOTAL")
    For i = 1 To ActiveSheet.Range("NB_GROUPES") - 1
        NbRestant = ActiveSheet.Range("NB_GROUPES") - i + 1
        Moyenne = EffectifRestant / NbRestant
        Tranche = Moyenne / 10
        EcartBSup = Moyenne - Tranche * (10 - ActiveSheet.Range("NIV_HETERO"))
        ' Pour le Random, on arrondit à l'entier supérieur (2.5 -> 3)
        Randomize
        EcartAlea = Int(Application.WorksheetFunction.RoundUp(EcartBSup, 0) * Rnd)
        Signe = 1 + Int(2 * Rnd)
        If Signe = 1 Then EffectifGroupe = Moyenne - EcartAlea Else EffectifGroupe = Moyenne + EcartAlea
        ActiveSheet.ListObjects("TabEffectifAleatoire").ListColumns("Effectif Aléatoire").DataBodyRange(i) = EffectifGroupe
        EffectifRestant = EffectifRestant - EffectifGroupe
    Next i
    ' pour le dernier groupe, on affecte la différence
    EffectifGroupe = EffectifRestant
    ActiveSheet.ListObjects("TabEffectifAleatoire").ListColumns("Effectif Aléatoire").DataBodyRange(i) = EffectifGroupe
    
    '--------
    ' Etape 2
    '--------
    ' sur les 2 colonnes suivantes, on va générer un table temporaire des Grooupes
    ' - colonne COL_EFF : n° de Groupe
    '   Groupe 1 pour les n1 premières lignes où n1 correspond au 1er Effectif calculé
    '   Groupe 2 pour les n2 lignes suivantes où n2 correspond au 2ème ... Effectif calculé
    ' - colonne COL_TRI : random pour effectuer un tri aléatoire de la colonne précédente
    Application.ScreenUpdating = False
    ActiveSheet.Columns(Range("COL_EFF").Column).ClearContents
    ActiveSheet.Columns(Range("COL_TRI").Column).ClearContents
    j = 1
    For i = 1 To ActiveSheet.Range("NB_GROUPES")
        EffectifGroupe = ActiveSheet.ListObjects("TabEffectifAleatoire").ListColumns("Effectif Aléatoire").DataBodyRange(i)
        ActiveSheet.Range(Cells(j, Range("COL_EFF").Column), Cells(j - 1 + EffectifGroupe, Range("COL_EFF").Column)) = i
        j = j + EffectifGroupe
    Next i
    ActiveSheet.Range(Cells(1, Range("COL_TRI").Column), Cells(Range("EFFECTIF_TOTAL"), Range("COL_TRI").Column)) = "=RAND()"
    ActiveSheet.Range(Cells(1, Range("COL_EFF").Column), Cells(Range("EFFECTIF_TOTAL"), Range("COL_TRI").Column)).Sort _
        Range(Cells(1, ActiveSheet.Range("COL_TRI").Column), Cells(Range("EFFECTIF_TOTAL"), Range("COL_TRI").Column)), Header:=xlNo
        
    '--------
    ' Etape 3
    '--------
    'Copie directe de la colonne COL_EFF dans la colonne Groupe de la feuille Données
    Range(Cells(1, ActiveSheet.Range("COL_EFF").Column), Cells(Range("EFFECTIF_TOTAL"), Range("COL_EFF").Column)).Copy
    Sheets(F_DONNEES).Activate
    Sheets(F_DONNEES).ListObjects("TabDonnées").ListColumns("Groupe").DataBodyRange(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Sheets(F_CALCUL).Activate
    ActiveSheet.Columns(Range("COL_EFF").Column).ClearContents
    ActiveSheet.Columns(Range("COL_TRI").Column).ClearContents
    Application.ScreenUpdating = True
End Sub

XL 2016 Répartir dans des Groupes d'Effectifs Aléatoires ... mais pas trop

crocrocro

XLDnaute Impliqué

Pièces jointes

crocrocro

crocrocro

XLDnaute Impliqué

crocrocro

XLDnaute Impliqué

Pièces jointes

Discussions similaires