Ceci est une page optimisée pour les mobiles. Cliquez sur ce texte pour afficher la vraie page.

code vba combinaison 5 numéro sur 49

julien clerc

XLDnaute Junior
salut a tous,
je cherche désespérément un code vba pour calculer et afficher toutes combinaisons de 5 numéros sur 49 ! sans doublon!
merci! de votre aides !
 

julien clerc

XLDnaute Junior
Re : code vba combinaison 5 numéro sur 49

merci kenDed ça marche parfaitement .
peut tu me dire juste si il une modification a faire pour supprimer toute les combinaisons à 5 numéros impair et à 5 numéros pair
merci encore
 

KenDev

XLDnaute Impliqué
Re : code vba combinaison 5 numéro sur 49

Re,

Relis le code de Roger (post 27) et rajoute sa condition (en adaptant le nom des variables) à la ligne
Code:
If Tb(1, n1) <> Tb(2, n2) And Tb(1, n1) <> Tb(3, n3) And _
                            Tb(1, n1) <> Tb(4, n4) And Tb(1, n1) <> Tb(5, n5) And _
                            Tb(2, n2) <> Tb(3, n3) And Tb(2, n2) <> Tb(4, n4) And _
                            Tb(2, n2) <> Tb(5, n5) And Tb(3, n3) <> Tb(4, n4) And _
                            Tb(3, n3) <> Tb(5, n5) And Tb(4, n4) <> Tb(5, n5) Then
Avec tous les codes présent sur ce fil tu devrais pouvoir faire à peu près ce que tu veux. Essayes de comprendre les codes fournis quitte à poser des questions précises sur ceux ci. Cordialement

KD
 

ROGER2327

XLDnaute Barbatruc
Re : code vba combinaison 5 numéro sur 49

Bonsoir à tous


Je n'ai pas suivi l'évolution de la discussion depuis quelques jours et ce que je vais montrer n'est peut-être plus d'actualité. Mais comme j'ai fait des choses, je livre...

J'ai repris à zéro la question de l'engendrement des combinaisons. J'obtiens le code qui suit, plus rapide que mes essais précédents. En pratique, on ne verra pas de différence sensible en temps d'exécution puisque l'affichage des résultats n'est pas accéléré. C'est donc juste pour la beauté du geste...

À noter que ce code n'utilise plus la fonction Combin d'Excel.

Version pour obtenir la sortie sous forme de tableau de texte :
VB:
Sub toto130a(a%, b%)
Dim d%, i%, j%, k%, p&, q&, r&, w$, Tv%(), Tw$(), ModeCalc&
    If a < b Or b < 1 Then Exit Sub
    Sheets.Add '***
    With Application: .ScreenUpdating = 0: ModeCalc = .Calculation: .Calculation = -4135: .EnableEvents = 0: End With
    r = Rows.Count
    d = a - b
    ReDim Tv(1 To b): For i = 1 To b: Tv(i) = i: Next
    Do
        ReDim Tw(r - 1, 0)
        Do
            w = Tv(1): For i = 2 To b: w = w & " " & Tv(i): Next: Tw(p, 0) = w
            p = p + 1
            j = 0
            For i = b To 1 Step -1
                If Tv(i) < d + i Then Tv(i) = Tv(i) + 1: For k = 1 To j: Tv(i + k) = Tv(i) + k: Next: Exit For
                j = j + 1
            Next
        Loop While i And p < r
        [A1].Resize(p, 1).Offset(, q).Value = Tw
        q = q + 1
        p = 0
    Loop While j < b
    Cells.EntireColumn.AutoFit
    With Application: .EnableEvents = 1: .Calculation = ModeCalc: .ScreenUpdating = 1: End With
End Sub
Version pour obtenir la sortie sous forme de tableau de nombres :
VB:
Sub toto131a(a%, b%)
Dim d%, i%, j%, k%, p&, q&, r&, Tv%(), Tw%(), ModeCalc&
    If a < b Or b < 1 Then Exit Sub
    Sheets.Add '***
    With Application: .ScreenUpdating = 0: ModeCalc = .Calculation: .Calculation = -4135: .EnableEvents = 0: End With
    r = Rows.Count
    d = a - b
    ReDim Tv(1 To b): For i = 1 To b: Tv(i) = i: Next
    Do
        ReDim Tw(r - 1, 1 To b)
        Do
            For i = 1 To b: Tw(p, i) = Tv(i): Next
            p = p + 1
            j = 0
            For i = b To 1 Step -1
                If Tv(i) < d + i Then Tv(i) = Tv(i) + 1: For k = 1 To j: Tv(i + k) = Tv(i) + k: Next: Exit For
                j = j + 1
            Next
        Loop While i And p < r
        [A1].Resize(p, b).Offset(, q).Value = Tw
        q = q + b + 1
        p = 0
    Loop While j < b
    Cells.EntireColumn.AutoFit
    With Application: .EnableEvents = 1: .Calculation = ModeCalc: .ScreenUpdating = 1: End With
End Sub


ROGER2327
#5631


Samedi 21 Pédale 139 (Saint Inscrit, Converti - fête Suprême Quarte)
25 Ventôse An CCXX, 9,9182h - thon
2012-W11-4T23:48:13Z
 
Dernière édition:
J

JJ1

Guest
Re : code vba combinaison 5 numéro sur 49

Bonjour à tous,

Merci Roger pour la réalisation de ces 2 macros.

Je souhaiterais, dans la prolongation du fil, effacer des cellules(plage A:C) contenant une chaîne de caractères texte (Colonne I).
Voici un petit exemple.
Merci pour votre contribution.
Bon samedi à tous.
 

Pièces jointes

  • effacement.xls
    25.5 KB · Affichages: 124
  • effacement.xls
    25.5 KB · Affichages: 120
  • effacement.xls
    25.5 KB · Affichages: 146

julien clerc

XLDnaute Junior
Re : code vba combinaison 5 numéro sur 49

salut a tous ! heureux de vous retrouver , pour un petits casse tête : sur une série de combinaisons a 5 numéros je souhaite modifier ma vba pour ne garder que les combinaison ou figure mon chiffre fétiche:le 7 voila ma vba :Sub combinaisons()
lin = 1
col = 1
For m = 1 To 49
For n = m + 1 To 49
For o = n + 1 To 49
For p = o + 1 To 49
For q = p + 1 To 49
Cells(lin, col) = m & " " & n & " " & " " & o & " " & p & " " & q
lin = lin + 1
If lin > 65536 Then
col = col + 1
lin = 1
End If
Next q
Next p
Next o
Next n
Next m
End Sub

Merci de votre aides
 

Pierrot93

XLDnaute Barbatruc
Re : code vba combinaison 5 numéro sur 49

Bonjour,

regarde peut être ceci :
Code:
Dim t() As Variant
t = Array(m, n, o, p, q)
If Not IsError(Application.Match(7, t, 0)) Then Cells(lin, col) = m & " " & n & " " & " " & o & " " & p & " " & q
Erase t

il eût été préférable que tu crées ta propre discussion...

bon après midi
@+
 

B Mohamed Khalid

XLDnaute Nouveau
 

B Mohamed Khalid

XLDnaute Nouveau
 

B Mohamed Khalid

XLDnaute Nouveau
Bonjour Pierrejean
Votre programme marche tres bien, seulement, j'aimerais bien ajouter une condition concernant la somme des 5 numéros...disons que j'aimerais avoir tous les 5 des 49 dont la somme (des 5 numéros) est comprise entre 80 et 180...Merci d'avance
 

pierrejean

XLDnaute Barbatruc
Bonjour Mohamed

A tester:
Code:
Sub comnbinaisons1()
num1 = Array(1, 2, 4, 9, 20, 40, 41)
num2 = Array(3, 5, 8, 15, 43, 44, 45)
num3 = Array(6, 12, 18, 23, 35, 37)
num4 = Array(10, 7, 16, 19, 38, 39, 40)
num5 = Array(31, 32, 33, 34, 42, 25, 26, 27, 28)
rc = Rows.Count
lignes = (UBound(num1) + 1) * (UBound(num2) + 1) * (UBound(num3) + 1) * (UBound(num4) + 1) * (UBound(num5) + 1)
col = Int(lignes / rc) + 1
If col > 1 Then
  lig = rc
Else
  lig = lignes
End If
Dim tablo()
ReDim tablo(1 To lig, 1 To col)
ligne = 1
coln = 1
For n1 = LBound(num1) To UBound(num1)
  For n2 = LBound(num2) To UBound(num2)
    For n3 = LBound(num3) To UBound(num3)
      For n4 = LBound(num4) To UBound(num4)
        For n5 = LBound(num5) To UBound(num5)
         somme = num1(n1) + num2(n2) + num3(n3) + num4(n4) + num5(n5)
         If somme > 79 And somme < 181 Then
                tablo(ligne, coln) = num1(n1) & " " & num2(n2) & " " & num3(n3) & " " & num4(n4) & " " & num5(n5)
                 ligne = ligne + 1
         End If
         If ligne > rc Then
          ligne = 1
          coln = coln + 1
         End If
        Next
      Next
    Next
  Next
Next
Range(Cells(1, 1), Cells(lig, col)).Value = tablo
End Sub
 

B Mohamed Khalid

XLDnaute Nouveau
Re : code vba combinaison 5 numéro sur 49

Re

Merci ROGER
J'apprecie notamment la façon d'affecter le tableau final
Merci cher ami, c'est Parfait , sauf que le 5ème numéro est placé avant le quatrième...petite erreur de programmation j'imagine ?
 

B Mohamed Khalid

XLDnaute Nouveau
Bonjour cher ami et mille merci...les numéros des combinaisons crées par le programme ne sont pas croissants...Je joint à ce commentaire la vue d'une partie des combinaisons non croissantes
Voici une par du fichier crée
9 43 37 7 42
9 43 37 7 25
9 43 37 7 26
9 43 37 7 27
9 43 37 7 28
9 43 37 16 31
9 43 37 16 32
9 43 37 16 33
9 43 37 16 34
9 43 37 16 42
9 43 37 16 25
9 43 37 16 26
9 43 37 16 27
9 43 37 16 28
9 43 37 19 31
9 43 37 19 32
9 43 37 19 33
9 43 37 19 34
9 43 37 19 42
Les numéros sont chamboulés....
 

Discussions similaires

Réponses
6
Affichages
370
Les cookies sont requis pour utiliser ce site. Vous devez les accepter pour continuer à utiliser le site. En savoir plus…