code vba combinaison 5 numéro sur 49

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.
 

Fichiers joints

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
@+
 

julien clerc

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

:( non ça ne fonctionne pas je vais crées une discussion ta raisons
merci a +
 

B Mohamed Khalid

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

Re

avec encore un peu plus de patience:

Code:
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
                 If m Mod 2 <> 0 Or n Mod 2 <> 0 Or o Mod 2 <> 0 Or p Mod 2 <> 0 Or q Mod 2 <> 0 Then
                   Cells(lin, col) = m & " " & n & " " & " " & o & " " & p & " " & q
                   lin = lin + 1
                   If lin > 65536 Then
                     col = col + 1
                     lin = 1
                   End If
                  End If
                Next q
          Next p
     Next o
Next n
Next m
End Sub
 

B Mohamed Khalid

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

Bonsoir à tous,

Dans la configuration 49,5, un code 2 fois plus rapide que la première version de Pierre-Jean et 2,66 fois plus lent que la version Pierre-Jean & Roger mais qui a l'avantage d'être 'universel' si les deux variables 49 et 5 sont susceptibles de varier.

Cordialement

KD

ps : Ou l'on apprend que Roger a le poil épais.

VB:
Option Explicit

Sub test()
[QUOTE="B Mohamed Khalid, post: 20127186, member: 208047"][/QUOTE]


Bonjour ...
Comment faire pour  ajouter une autre condition lors de la création de la matrice ? par exemple une condition sur la somme des 5 chiffres qui devrait etre comprise par exemple entre 80 et 170 ? Merci pour votre amabilité et votre réactivité....Cordialement...

 
    Call AffComb(49, 5)
End Sub

Sub AffComb(a&, b&)
Dim i#, NbCmb#, Rg As Range, Tb(), j%, NbWrt#, NbRw&, m%, c%, Tc&(), s&
    If b > a Or b < 1 Or b > Columns.Count Then Exit Sub
    Application.ScreenUpdating = False: m = Application.Calculation: Application.Calculation = xlCalculationManual
    NbCmb = WorksheetFunction.Combin(a, b): NbWrt = NbCmb: ReDim Tc(1 To b)
    Do
        Sheets.Add: s = s + 1
        Do
            NbRw = Round(IIf(NbWrt > Rows.Count, Rows.Count, NbWrt)): ReDim Tb(1 To NbRw, 1 To b)
            If c = 0 And s = 1 Then
                For i = 1 To b
                    Tb(1, i) = i
                Next i
            Else
                For i = 1 To b
                    Select Case i
                        Case 1
                            Tb(1, i) = IIf(Tc(i + 1) = a - b + 2, Tc(i) + 1, Tc(i))
                        Case b
                            Tb(1, i) = IIf(Tc(i) = a, Tc(i - 1) + 1, Tc(i) + 1)
                        Case Else
                            Tb(1, i) = IIf(Tc(i + 1) = a - b + i + 1, IIf(Tc(i) = a - b + i, Tc(i - 1) + 1, Tc(i) + 1), Tc(i))
                    End Select
                Next i
            End If
            For i = 2 To NbRw
                For j = 1 To b
                    Select Case j
                        Case 1
                            Tb(i, j) = IIf(Tb(i - 1, j + 1) = a - b + 2, Tb(i - 1, j) + 1, Tb(i - 1, j))
                        Case b
                            Tb(i, j) = IIf(Tb(i - 1, j) = a, Tb(i, j - 1) + 1, Tb(i - 1, j) + 1)
                        Case Else
                            Tb(i, j) = IIf(Tb(i - 1, j + 1) = a - b + j + 1, IIf(Tb(i - 1, j) = a - b + j, Tb(i, j - 1) + 1, Tb(i - 1, j) + 1), Tb(i - 1, j))
                    End Select
            Next j, i
            Set Rg = Range(Cells(1, c * (b + 1) + 1), Cells(NbRw, c * (b + 1) + b)): Rg = Tb
            NbWrt = Round(NbWrt - NbRw): If NbWrt = 0 Then Exit Do
            For i = 1 To b
                Tc(i) = Tb(NbRw, i)
            Next i
            c = c + 1
        Loop Until c * (b + 1) + b > Columns.Count
        c = 0
    Loop Until NbWrt = 0
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True: Application.Calculation = m
End Sub
 

B Mohamed Khalid

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

Re

avec encore un peu plus de patience:

Code:
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
                 If m Mod 2 <> 0 Or n Mod 2 <> 0 Or o Mod 2 <> 0 Or p Mod 2 <> 0 Or q Mod 2 <> 0 Then
                   Cells(lin, col) = m & " " & n & " " & " " & o & " " & p & " " & q
                   lin = lin + 1
                   If lin > 65536 Then
                     col = col + 1
                     lin = 1
                   End If
                  End If
                Next q
          Next p
     Next o
Next n
Next m
End Sub
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

Bonsoir à tous,

Dans la configuration 49,5, un code 2 fois plus rapide que la première version de Pierre-Jean et 2,66 fois plus lent que la version Pierre-Jean & Roger mais qui a l'avantage d'être 'universel' si les deux variables 49 et 5 sont susceptibles de varier.

Cordialement

KD

ps : Ou l'on apprend que Roger a le poil épais.

VB:
Option Explicit

Sub test()
    Call AffComb(49, 5)
End Sub

Sub AffComb(a&, b&)
Dim i#, NbCmb#, Rg As Range, Tb(), j%, NbWrt#, NbRw&, m%, c%, Tc&(), s&
    If b > a Or b < 1 Or b > Columns.Count Then Exit Sub
    Application.ScreenUpdating = False: m = Application.Calculation: Application.Calculation = xlCalculationManual
    NbCmb = WorksheetFunction.Combin(a, b): NbWrt = NbCmb: ReDim Tc(1 To b)
    Do
        Sheets.Add: s = s + 1
        Do
            NbRw = Round(IIf(NbWrt > Rows.Count, Rows.Count, NbWrt)): ReDim Tb(1 To NbRw, 1 To b)
            If c = 0 And s = 1 Then
                For i = 1 To b
                    Tb(1, i) = i
                Next i
            Else
                For i = 1 To b
                    Select Case i
                        Case 1
                            Tb(1, i) = IIf(Tc(i + 1) = a - b + 2, Tc(i) + 1, Tc(i))
                        Case b
                            Tb(1, i) = IIf(Tc(i) = a, Tc(i - 1) + 1, Tc(i) + 1)
                        Case Else
                            Tb(1, i) = IIf(Tc(i + 1) = a - b + i + 1, IIf(Tc(i) = a - b + i, Tc(i - 1) + 1, Tc(i) + 1), Tc(i))
                    End Select
                Next i
            End If
            For i = 2 To NbRw
                For j = 1 To b
                    Select Case j
                        Case 1
                            Tb(i, j) = IIf(Tb(i - 1, j + 1) = a - b + 2, Tb(i - 1, j) + 1, Tb(i - 1, j))
                        Case b
                            Tb(i, j) = IIf(Tb(i - 1, j) = a, Tb(i, j - 1) + 1, Tb(i - 1, j) + 1)
                        Case Else
                            Tb(i, j) = IIf(Tb(i - 1, j + 1) = a - b + j + 1, IIf(Tb(i - 1, j) = a - b + j, Tb(i, j - 1) + 1, Tb(i - 1, j) + 1), Tb(i - 1, j))
                    End Select
            Next j, i
            Set Rg = Range(Cells(1, c * (b + 1) + 1), Cells(NbRw, c * (b + 1) + b)): Rg = Tb
            NbWrt = Round(NbWrt - NbRw): If NbWrt = 0 Then Exit Do
            For i = 1 To b
                Tc(i) = Tb(NbRw, i)
            Next i
            c = c + 1
        Loop Until c * (b + 1) + b > Columns.Count
        c = 0
    Loop Until NbWrt = 0
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True: Application.Calculation = m
End Sub
Re : code vba combinaison 5 numéro sur 49

Bonsoir à tous,

Dans la configuration 49,5, un code 2 fois plus rapide que la première version de Pierre-Jean et 2,66 fois plus lent que la version Pierre-Jean & Roger mais qui a l'avantage d'être 'universel' si les deux variables 49 et 5 sont susceptibles de varier.

Cordialement

KD

ps : Ou l'on apprend que Roger a le poil épais.

VB:
Option Explicit

Sub test()
    Call AffComb(49, 5)
End Sub

Sub AffComb(a&, b&)
Dim i#, NbCmb#, Rg As Range, Tb(), j%, NbWrt#, NbRw&, m%, c%, Tc&(), s&
    If b > a Or b < 1 Or b > Columns.Count Then Exit Sub
    Application.ScreenUpdating = False: m = Application.Calculation: Application.Calculation = xlCalculationManual
    NbCmb = WorksheetFunction.Combin(a, b): NbWrt = NbCmb: ReDim Tc(1 To b)
    Do
        Sheets.Add: s = s + 1
        Do
            NbRw = Round(IIf(NbWrt > Rows.Count, Rows.Count, NbWrt)): ReDim Tb(1 To NbRw, 1 To b)
            If c = 0 And s = 1 Then
                For i = 1 To b
                    Tb(1, i) = i
                Next i
            Else
                For i = 1 To b
                    Select Case i
                        Case 1
                            Tb(1, i) = IIf(Tc(i + 1) = a - b + 2, Tc(i) + 1, Tc(i))
                        Case b
                            Tb(1, i) = IIf(Tc(i) = a, Tc(i - 1) + 1, Tc(i) + 1)
                        Case Else
                            Tb(1, i) = IIf(Tc(i + 1) = a - b + i + 1, IIf(Tc(i) = a - b + i, Tc(i - 1) + 1, Tc(i) + 1), Tc(i))
                    End Select
                Next i
            End If
            For i = 2 To NbRw
                For j = 1 To b
                    Select Case j
                        Case 1
                            Tb(i, j) = IIf(Tb(i - 1, j + 1) = a - b + 2, Tb(i - 1, j) + 1, Tb(i - 1, j))
                        Case b
                            Tb(i, j) = IIf(Tb(i - 1, j) = a, Tb(i, j - 1) + 1, Tb(i - 1, j) + 1)
                        Case Else
                            Tb(i, j) = IIf(Tb(i - 1, j + 1) = a - b + j + 1, IIf(Tb(i - 1, j) = a - b + j, Tb(i, j - 1) + 1, Tb(i - 1, j) + 1), Tb(i - 1, j))
                    End Select
            Next j, i
            Set Rg = Range(Cells(1, c * (b + 1) + 1), Cells(NbRw, c * (b + 1) + b)): Rg = Tb
            NbWrt = Round(NbWrt - NbRw): If NbWrt = 0 Then Exit Do
            For i = 1 To b
                Tc(i) = Tb(NbRw, i)
            Next i
            c = c + 1
        Loop Until c * (b + 1) + b > Columns.Count
        c = 0
    Loop Until NbWrt = 0
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True: Application.Calculation = m
End Sub
Re : code vba combinaison 5 numéro sur 49

Re

Merci ROGER
J'apprecie notamment la façon d'affecter le tableau final
Re : code vba combinaison 5 numéro sur 49

Bonjour à tous


À pierrejean : on peut faire un poil (au pif ? pâle ?) plus rapide avec un tableau. J'en profite pour adapter votre procédure aux différentes tailles de feuille.
VB:
Sub combinaisons()
Dim lin&, col&, rc&, m%, n%, o%, p%, q%, tir$()
lin = 1
col = 0
rc = Rows.Count
ReDim tir(1 To rc, 0)
    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
                        If (m Mod 2) + (n Mod 2) + (o Mod 2) + (p Mod 2) + (q Mod 2) <> 0 Then '***
                            tir(lin, col) = m & " " & n & " " & o & " " & p & " " & q
                            lin = lin + 1
                            If lin > rc Then
                                col = col + 1
                                lin = 1
                                ReDim Preserve tir(1 To rc, col)
                            End If
                        End If '***
                    Next q
                Next p
            Next o
        Next n
    Next m
    Range(Cells(1, 1), Cells(rc, col + 1)).Value = tir
End Sub


ROGER2327
#5610


Vendredi 13 Pédale 139 (Sainte Valburge - fête Suprême Quarte)
17 Ventôse An CCXX, 5,8664h - doronic
2012-W10-3T14:04:45Z
Re : code vba combinaison 5 numéro sur 49

Re

avec encore un peu plus de patience:

Code:
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
                 If m Mod 2 <> 0 Or n Mod 2 <> 0 Or o Mod 2 <> 0 Or p Mod 2 <> 0 Or q Mod 2 <> 0 Then
                   Cells(lin, col) = m & " " & n & " " & " " & o & " " & p & " " & q
                   lin = lin + 1
                   If lin > 65536 Then
                     col = col + 1
                     lin = 1
                   End If
                  End If
                Next q
          Next p
     Next o
Next n
Next m
End Sub
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
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....
 

pierrejean

XLDnaute Barbatruc
Re
Je n'ai repris mon code qu'en ajoutant la condition de la somme
S'il existe d'autres contraintes il y a lieu de tout revoir
précisez l’énoncé complet du problème S.V.P
 

B Mohamed Khalid

XLDnaute Nouveau
Re
Je n'ai repris mon code qu'en ajoutant la condition de la somme
S'il existe d'autres contraintes il y a lieu de tout revoir
précisez l’énoncé complet du problème S.V.P
Bonjour Pierrejean
Tout d'abord je vous remercie pour votre amabilité et je salue votre réactivité
L'énoncé complet du probleme est le suivant :
1. Créer tous les 6 / 49 avec des combinaisons triée sur l'ordre croissant des nombres...(1,2,3,4,5,6) mais jamais (15,7,22,33,12,48)..
2. Ne créer que les combinaisons dont la somme des 6 chiffres est comprise entre 100 et 200 : "
- (a+b+c+d+e+f)>99
- (a+b+c+d+e+f) <201
- ne pas accepter des combinaisons de 6 numéros avec plus de 5 nombres pairs
- ne pas accepter des combinaisons de 6 numéros avec plus de 5 nombres impairs.
Cordialement
 

B Mohamed Khalid

XLDnaute Nouveau
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
Merci pour le conseil cher ami..la seule fois ou j'ai appris à programmer c'était avec DBase III plus...j'aimerais bien que vous m'aidiez à comprendre le programme suivant...je vous serais gré d'ajouter à la fin de chaque ligne une explication de celle-ci...entre cotes ou entre guillemets.Vous me rendrez un grand service. merci d'avance de m'apprendre à pêcher ... Cordialement

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
 

pierrejean

XLDnaute Barbatruc
Re

A tester (fonctionne mais je manque de temps (et de gout) pour contrôler )
Code:
Sub combinaisons()
'liste de 1 a 49 sans les 7 12 15 22 33 48
num1 = Array(1, 2, 3, 4, 5, 6, 8)
num2 = Array(9, 10, 11, 13, 14, 16, 17)
num3 = Array(18, 19, 20, 21, 23, 24, 25)
num4 = Array(26, 27, 28, 29, 30, 31, 32)
num5 = Array(34, 35, 36, 37, 38, 39, 40)
num6 = Array(41, 42, 43, 44, 45, 46, 47, 49)
'nombre max de lignes
rc = Rows.Count
'nombre theorique de lignes de codes nb:il sera diminué par les restrictions
lignes = (UBound(num1) + 1) * (UBound(num2) + 1) * (UBound(num3) + 1) * (UBound(num4) + 1) * (UBound(num5) + 1) * (UBound(num6) + 1)
'nombre de colonnes pour enregistrer le nbre theorique de codes
col = Int(lignes / rc) + 1
If col > 1 Then
lig = rc
Else
lig = lignes
End If
'dimensions du tableau de resultat
Dim tablo()
ReDim tablo(1 To lig, 1 To col)
ligne = 1
coln = 1
'bouclage sur les array des nbres constituants des codes
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)
For n6 = LBound(num6) To UBound(num6)
'evaluation de la somme
somme = num1(n1) + num2(n2) + num3(n3) + num4(n4) + num5(n5) + num6(n6)
'restriction concernant la somme
If somme > 99 And somme < 201 Then
'calcul des pairs et impairs
  npairs = 6 - num1(n1) Mod 2 + num2(n2) Mod 2 + num3(n3) Mod 2 + num4(n4) Mod 2 + num5(n5) Mod 2 + num6(n6) Mod 2
  nimpairs = num1(n1) Mod 2 + num2(n2) Mod 2 + num3(n3) Mod 2 + num4(n4) Mod 2 + num5(n5) Mod 2 + num6(n6) Mod 2
  'restriction concernant la parité
  If npairs < 6 And nimpairs < 6 Then
  'si ok remplissage du tableau de resultat
      tablo(ligne, coln) = num1(n1) & " " & num2(n2) & " " & num3(n3) & " " & num4(n4) & " " & num5(n5) & " " & num6(n6)
      ligne = ligne + 1
   End If
End If
'eventuellement ajout d'une colonne
If ligne > rc Then
ligne = 1
coln = coln + 1
End If
Next
Next
Next
Next
Next
Next
'restitution du tableau de resultat
Range(Cells(1, 1), Cells(lig, col)).Value = tablo
End Sub
 

B Mohamed Khalid

XLDnaute Nouveau
Re

A tester (fonctionne mais je manque de temps (et de gout) pour contrôler )
Code:
Sub combinaisons()
'liste de 1 a 49 sans les 7 12 15 22 33 48
num1 = Array(1, 2, 3, 4, 5, 6, 8)
num2 = Array(9, 10, 11, 13, 14, 16, 17)
num3 = Array(18, 19, 20, 21, 23, 24, 25)
num4 = Array(26, 27, 28, 29, 30, 31, 32)
num5 = Array(34, 35, 36, 37, 38, 39, 40)
num6 = Array(41, 42, 43, 44, 45, 46, 47, 49)
'nombre max de lignes
rc = Rows.Count
'nombre theorique de lignes de codes nb:il sera diminué par les restrictions
lignes = (UBound(num1) + 1) * (UBound(num2) + 1) * (UBound(num3) + 1) * (UBound(num4) + 1) * (UBound(num5) + 1) * (UBound(num6) + 1)
'nombre de colonnes pour enregistrer le nbre theorique de codes
col = Int(lignes / rc) + 1
If col > 1 Then
lig = rc
Else
lig = lignes
End If
'dimensions du tableau de resultat
Dim tablo()
ReDim tablo(1 To lig, 1 To col)
ligne = 1
coln = 1
'bouclage sur les array des nbres constituants des codes
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)
For n6 = LBound(num6) To UBound(num6)
'evaluation de la somme
somme = num1(n1) + num2(n2) + num3(n3) + num4(n4) + num5(n5) + num6(n6)
'restriction concernant la somme
If somme > 99 And somme < 201 Then
'calcul des pairs et impairs
  npairs = 6 - num1(n1) Mod 2 + num2(n2) Mod 2 + num3(n3) Mod 2 + num4(n4) Mod 2 + num5(n5) Mod 2 + num6(n6) Mod 2
  nimpairs = num1(n1) Mod 2 + num2(n2) Mod 2 + num3(n3) Mod 2 + num4(n4) Mod 2 + num5(n5) Mod 2 + num6(n6) Mod 2
  'restriction concernant la parité
  If npairs < 6 And nimpairs < 6 Then
  'si ok remplissage du tableau de resultat
      tablo(ligne, coln) = num1(n1) & " " & num2(n2) & " " & num3(n3) & " " & num4(n4) & " " & num5(n5) & " " & num6(n6)
      ligne = ligne + 1
   End If
End If
'eventuellement ajout d'une colonne
If ligne > rc Then
ligne = 1
coln = coln + 1
End If
Next
Next
Next
Next
Next
Next
'restitution du tableau de resultat
Range(Cells(1, 1), Cells(lig, col)).Value = tablo
End Sub
Merci tres cher ami...Vous etes un ange...je testerais et vous rendrais compte
 

B Mohamed Khalid

XLDnaute Nouveau
Merci tres cher ami...Vous etes un ange...je testerais et vous rendrais compte
Sub combinaisons()
'liste de 1 a 49 sans les 7 12 15 22 33 48
num1 = Array(1, 2, 3, 4, 5, 6, 8)
num2 = Array(9, 10, 11, 13, 14, 16, 17)
num3 = Array(18, 19, 20, 21, 23, 24, 25)
num4 = Array(26, 27, 28, 29, 30, 31, 32)
num5 = Array(34, 35, 36, 37, 38, 39, 40)
num6 = Array(41, 42, 43, 44, 45, 46, 47, 49)
'nombre max de lignes
rc = Rows.Count
'nombre theorique de lignes de codes nb:il sera diminué par les restrictions
lignes = (UBound(num1) + 1) * (UBound(num2) + 1) * (UBound(num3) + 1) * (UBound(num4) + 1) * (UBound(num5) + 1) * (UBound(num6) + 1)
'nombre de colonnes pour enregistrer le nbre theorique de codes
col = Int(lignes / rc) + 1
If col > 1 Then
lig = rc
Else
lig = lignes
End If
'dimensions du tableau de resultat
Dim tablo()
ReDim tablo(1 To lig, 1 To col)
ligne = 1
coln = 1
'bouclage sur les array des nbres constituants des codes
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)
For n6 = LBound(num6) To UBound(num6)
'evaluation de la somme
somme = num1(n1) + num2(n2) + num3(n3) + num4(n4) + num5(n5) + num6(n6)
'restriction concernant la somme
If somme > 99 And somme < 201 Then
'calcul des pairs et impairs
npairs = 6 - num1(n1) Mod 2 + num2(n2) Mod 2 + num3(n3) Mod 2 + num4(n4) Mod 2 + num5(n5) Mod 2 + num6(n6) Mod 2
nimpairs = num1(n1) Mod 2 + num2(n2) Mod 2 + num3(n3) Mod 2 + num4(n4) Mod 2 + num5(n5) Mod 2 + num6(n6) Mod 2
'restriction concernant la parité
If npairs < 6 And nimpairs < 6 Then
'si ok remplissage du tableau de resultat
tablo(ligne, coln) = num1(n1) & " " & num2(n2) & " " & num3(n3) & " " & num4(n4) & " " & num5(n5) & " " & num6(n6)
ligne = ligne + 1
End If
End If
'eventuellement ajout d'une colonne
If ligne > rc Then
ligne = 1
coln = coln + 1
End If
Next
Next
Next
Next
Next
Next
'restitution du tableau de resultat
Range(Cells(1, 1), Cells(lig, col)).Value = tablo
End Sub

Voilà le résultat une fois le programme exécuté : il arrive à 1296 combinaisons, c'est à dire la combinaison (5 16 24 32 40 46) et il arrête, sachant que le total possible ne devrait pas être inférieur à quelques millions de combinaisons, désolé de vous déranger, mais je crois que quelque part, une instruction l'arrête à ce niveau...
 

Discussions similaires


Haut Bas