Combinaisons d'éléments avec maximum

[europeest]

Bonjour à tous

Nouveau sur le forum, je tente sans succès pour l'instant de resoudre le problème suivant (en pièce jointe)

J'ai une série de catégories (20 catégories) dont les valeurs peuvent être comprises entre 0 et 10. Le total des valeurs pour chaque combinaison potentielle est fixe et doit être égal à 71.

Je cherche à établir la liste de toutes les combinaisons potentielles sous la forme d'un tableau. J'ai essayé via divers IF etc..., RANDBETWEEN et autres, mais sans succès jusqu'à présent.

Avez-vous déjà résolu des questions similaires, quelle est l'approche à aborder?

Merci pour votre attention.
Cordialement

 

[pierrejean]

Re : Combinaisons d'éléments avec maximum

Bonjour moles

Une méthode de bourrin qui, j’espère, trouvera de la concurrence

 

[tototiti2008]

Re : Combinaisons d'éléments avec maximum

Bonjour à tous ,

m'en voudrait de laisser l'ami PierreJean seul, surtout s'il demande de la compagnie

 

[pierrejean]

Re : Combinaisons d'éléments avec maximum

Bonjour à tous

Très heureux de constater que globalement nos résultats concordent
Mais pour ce qui est de la compréhension de tes codes, mon cher Tototiti , j'ai comme un Trou !!!

 

[tototiti2008]

Re : Combinaisons d'éléments avec maximum

Bonjour PierreJean, Bonjour à tous,

Etant donné la question, l'ordre des chiffres (1-2-3-4-5-6-7) ne change jamais, on se contente de masquer certains d'entre eux pour les combinaisons. un trou c'est un chiffre masqué. Il y a jusqu'à 5 trous. Le tableau trou contient les rangs des chiffres masqués (rang de 1 à 7).
Au début, un trou au rang 7, puis je diminue le rang jusqu'à 1
Puis un deuxième trou au rang 7, et je remet le 1er au rang 6
Je descend toujours le premier trou jusqu'à ce qu'il atteigne la valeur de son indice (1)
Puis si je change le rang d'un autre trou, je redonne aux trous précédents le rang inférieur à celui changé
Trous doit évoluer comme ça :
7-0-0-0-0
6-0-0-0-0
5-0-0-0-0
...
1-0-0-0-0
6-7-0-0-0 'ajout d'un trou, on donne aux précédents la valeur inférieure
5-7-0-0-0
...
1-7-0-0-0
5-6-0-0-0 'changement de valeur d'un trou, on donne aux précédents la valeur inférieure
...
1-2-0-0-0
5-6-7-0-0 'ajout d'un trou, on donne aux précédents la valeur inférieure
...
La condition de sortie est que chaque trou ait la valeur de son indice
si je ne me trompe pas, le code devrait fonctionner pour plus de 7 valeurs (il suffit de redéfinir le nom Valos)

Edit : la méthode Poinçonneur des Lilas

 

[KenDev]

Re : Combinaisons d'éléments avec maximum

Bonjour à tous, bonjour PierreJean, Tototiti,

Une solution 'universelle' dans le code suivant. La sub écrit dans la feuille active. Faire varier les paramètres dans la Sub Main.

a = Nombre d'éléments total
Debut = Plus petit des rangs choisis (par omission rang 1)
Fin = Dernier des rangs choisis (par omission rang maximum = a)
SortieNumeric = False pour 1 combinaison texte par cellule, True pour 1 nombre par cellule (par omission False)

Exemples:
_ parmis 7 à partir du rang 2 en sortie texte (demande de Mole):

Call AllCombins(7, 2)

_ parmis 17, du rang 7 à 9 en sortie numérique

Call AllCombins(17, 7, 9, True)

Cordialement

KD

Dim Cb()
Sub Main(): Call AllCombins(7, 2, 0, False): End Sub
Private Sub AllCombins(ByVal a%, Optional Debut% = 1, Optional Fin% = 0, Optional SortieNumeric As Boolean = False)
    Dim i%, j&, r&, k%
    Application.ScreenUpdating = False: Application.Calculation = xlCalculationManual
    If Fin = 0 Then Fin = a
    If Debut < 1 Or Fin < Debut Or Fin > a Then Exit Sub
    For i = Debut To Fin
        ReDim Cb(i)
        For j = 1 To i - 1: Cb(j) = j: Next j
        Cb(j) = Cb(j - 1)
        For j = 1 To CombinNb(a, i)
            Call CombinNext(a)
            r = r + 1
            If SortieNumeric Then
                For k = 1 To i: Cells(r, k) = Cb(k): Next k
            Else
                Cells(r, 1) = Join(Cb)
            End If
        Next j
    Next i
    Application.Calculation = xlCalculationAutomatic
End Sub
Private Sub CombinNext(ByVal a%)
    Dim b%, i%
    b = UBound(Cb)
    If b = a Then Cb(b) = Cb(b) + 1: Exit Sub
    If b = 1 Then Cb(1) = Cb(1) + 1 Else Cb(1) = Cb(1) - (Cb(2) = a - b + 2)
    For i = 2 To b - 1
        If Cb(i + 1) = a - b + i + 1 Then Cb(i) = Cb(i + (Cb(i) = a - b + i)) + 1
    Next i
    If b > 1 Then
        If Cb(b) = a Then Cb(b) = Cb(b - 1) + 1 Else Cb(b) = Cb(b) + 1
    End If
End Sub
Private Function CombinNb(ByVal a%, ByVal b%) As Double
    Dim c%
    c = a - b
    If b < c Then c = b
    If c = 0 Then CombinNb = 1 Else CombinNb = MathFactoriel(a, c) / MathFactoriel(c)
End Function
Private Function MathFactoriel(ByVal Nb%, Optional Iter% = 0) As Double
    Dim i&, n&
    If Iter = 0 Then Iter = Nb
    MathFactoriel = 1
    For i = 0 To Iter - 1: MathFactoriel = MathFactoriel * (Nb - i): Next i
End Function