Faire des combinaisons à partir d' un ensemble de chiffres

Bonjour à tous,

bon lundi.

Je viens vers vous afin que vous m’ aidiez à gagner un temps fou.

Vous verrez que ma demande est très simple à comprendre.

Dans la pièce jointe vous trouverez un tableau avec des chiffres allant de 1 à 30.

Mon souhait est de créer une macro qui me fasse toutes les combinaisons possibles avec ces chiffres.

IL y a 2 objectifs à respecter :

_ Le premier : La taille des combinaisons qui doit être de 5.

_ Le deuxième : on ne peut trouver dans une même combinaison 2 chiffres appartenant à la même ligne. ( Pour plus de compréhension consultez le fichier joint. )

Ainsi, il sera impossible d’ avoir 1 et 2 dans la même combinaison, ni 21 et 22.

Donc les combinaisons suivantes sont à exclure :

9-14-15-29-30

1-13-14-21-30

7-15-16-27-29

13-15-18-25-26

En revanche les combinaisons suivantes sont bonnes :

4-5-11-17-24

18-19-22-23-28

2-6-11-26-27

Car bien que ces chiffres se suivent dans l’ ordre chronologique , dans le tableau ils ne figurent pas sur la même ligne.

Voilà, je pense que vous avez compris.

Si vous avez des questions n’ hésitez pas à me les poser.

Merci d’ avance à tous ceux qui se pencheront sur mon problème.

142.506 combinaisons moins les erreurs, c'est ça ? = +96.000

Sub combinaisons()
     Dim aA, aB, aOut, aAux(1 To 5), aExcl(1 To 15)
     t = Timer
     aA = Range("A1:B15")
     Set dict = CreateObject("scripting.dictionary")
     For i = 1 To UBound(aA)
          aExcl(i) = "-" & aA(i, 1) & "-" & aA(i, 2) & "-"
          For j = 1 To UBound(aA, 2)
               dict(aA(i, j)) = vbEmpty
          Next
     Next
     aB = dict.keys
     ReDim aOut(1 To WorksheetFunction.Combin(dict.Count, 5), 1 To 1)

     For j = 1 To 5
          aAux(j) = j - 1
     Next

     Do
          s = ""
          For j = 1 To UBound(aAux)
               s = s & "-" & aB(aAux(j))
          Next
          s = s & "-"

          For j = 1 To UBound(aExcl)
               b = (InStr(1, s, aExcl(j), 1) > 0)
               If b Then Exit For
          Next

          If Not b Then
               ptr = ptr + 1
               aOut(ptr, 1) = s
          End If

          aAux(UBound(aAux)) = aAux(UBound(aAux)) + 1
          If aAux(UBound(aAux)) > UBound(aB) Then
               For j = UBound(aAux) To 2 Step -1
                    If aAux(j) > UBound(aB) - UBound(aAux) + j Then
                         aAux(j - 1) = aAux(j - 1) + 1
                         For k = j To UBound(aAux)
                              aAux(k) = aAux(k - 1) + 1
                         Next
                    Else
                         Exit For
                    End If
               Next
          End If
     Loop While aAux(1) <= UBound(aB) - UBound(aAux) + 1

     T2 = Timer

     With Range("D1")
          .EntireColumn.ClearContents
          .Resize(ptr).Value = aOut
     End With

     MsgBox Format(ptr, "0,000") & " combinaisons" & vbLf & Format(T2 - t, "0.0\s")
End Sub

Trop fort , vraiment je n'y serais pas arrivé sans ton aide BsAlv. J' ai vérifié ton travail et c' est parfaitement ce que je voulais, il ne manque pas une seule combinaison lool.

Je te remercie infiniment d' avoir pris le temps pour moi.

J' encourage aussi tous les membres à continuer ce travail d' entre-aide.

BsAlv je te souhaite une bonne fin de journée

merci et aussi une bonne journée