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 ! :(
 

pierrejean

XLDnaute Barbatruc
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
 

ROGER2327

XLDnaute Barbatruc
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
 
Dernière édition:

KenDev

XLDnaute Impliqué
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
 

ROGER2327

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

Bonjour à tous


À KenDev

Belle démonstration de manipulation des tableaux ! Je n'ai pas décortiqué votre méthode, efficace au demeurant. Mais je dois faire quelques remarques sur la comparaison des performances des différentes solutions en présence.
Ce que vous avez mesuré est ce qu'on voit. Et je partage vos conclusions.
Mais cela ne dit rien de la qualité du code. En effet, votre code renvoie chaque combinaison dans cinq cellules numériques alors que les autres codes renvoient chaque combinaison dans une cellule texte. Et cela change tout ! On le sait, l'interface graphique d'Excel est exécrable : en exécutant votre code brut, j'obtiens le résultat en ~29,5s, avec ma version je l'obtiens en ~12s.
Si je supprime l'affichage (instruction Rg = Tb dans votre code, la dernière ligne dans le mien), le temps d'exécution tombe à ~6s pour votre code, et à ~5s pour le mien. On voit qu'Excel passe le plus clair de son temps à se dépatouiller avec ses procédures internes... ...et que votre code est bien plus rapide qu'il n'y parait de prime abord.

Mieux, en nettoyant un peu, votre code peut être beaucoup plus rapide. Je n'ai pas touché à la méthode (que je n'ai pas analysée, comme je l'ai dit plus haut), j'ai seulement bricolé la syntaxe :
VB:
Sub AffComb2(a&, b&)
Dim i&, j&, NbCmb#, Tb&%(), NbWrt#, NbRw&, m&, c%, Tc%(), s&, d&
    If b > a Or b < 2 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)
    d = a - b
    Do
        Sheets.Add: s = s + 1
        Do
            If NbWrt > Rows.Count Then NbRw = Rows.Count Else NbRw = 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
                Tb(1, 1) = Tc(1) - (Tc(2) = d + 2)
                For i = 2 To b - 1
                    If Tc(i + 1) = d + i + 1 Then Tb(1, i) = Tc(i + (Tc(i) = d + i)) + 1 Else Tb(1, i) = Tc(i)
                Next i
                Tb(1, b) = Tc(b + (Tc(b) = a)) + 1
            End If
            For i = 2 To NbRw
                Tb(i, 1) = Tb(i - 1, 1) - (Tb(i - 1, 2) = d + 2)
                For j = 2 To b - 1
                    If Tb(i - 1, j + 1) = d + j + 1 Then
                        If Tb(i - 1, j) = d + j Then Tb(i, j) = Tb(i, j - 1) + 1 Else Tb(i, j) = Tb(i - 1, j) + 1
                    Else
                        Tb(i, j) = Tb(i - 1, j)
                    End If
                Next j
                If Tb(i - 1, b) = a Then Tb(i, b) = Tb(i, b - 1) + 1 Else Tb(i, b) = Tb(i - 1, b) + 1
            Next i
            Cells(1, 1).Resize(NbRw, b).Offset(0, c * (b + 1)).Value = 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
Résultat : ~24s avec affichage du résultat, ~1,2s sans affichage.
(Le gain se fait essentiellement par l'élimination des IIf(...) bien commodes mais désastreux en temps d'exécution. Une instruction IIf(condition, expr1, expr2) évalue expr1 et expr2 avant de regarder laquelle des deux s'impose par la condition, alors qu'une structure If condition Then expr1 Else expr2 n'évalue que l'expression requise par la condition. La suppression des Select Case ... End Select en gérant autrement les index de boucle, et le typage un peu plus strict des variables font le reste.

Pour obtenir une amélioration du résultat visible, je n'ai rien trouvé de mieux que de dégrader la performance du code pour revenir à l'affichage sous forme "1 2 3 4 5" :
VB:
Sub AffComb4(a&, b&)
Dim i&, j&, NbCmb#, Tb%(), NbWrt#, NbRw&, m&, c%, Tc%(), s&, d&, x$, Td$()
    If b > a Or b < 2 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)
    d = a - b
    Do
        Sheets.Add: s = s + 1
        Do
            If NbWrt > Rows.Count Then NbRw = Rows.Count Else NbRw = NbWrt
            ReDim Tb(1 To NbRw, 1 To b)
            ReDim Td(1 To NbRw, 0)
            If c = 0 And s = 1 Then
                Tb(1, 1) = 1
                x = "1"
                For i = 2 To b
                    Tb(1, i) = i
                    x = x & " " & i
                Next i
            Else
                Tb(1, 1) = Tc(1) - (Tc(2) = d + 2)
                x = Tb(1, 1)
                For i = 2 To b - 1
                    If Tc(i + 1) = d + i + 1 Then Tb(1, i) = Tc(i + (Tc(i) = d + i)) + 1 Else Tb(1, i) = Tc(i)
                    x = x & " " & Tb(1, i)
                Next i
                Tb(1, b) = Tc(b + (Tc(b) = a)) + 1
                x = x & " " & Tb(1, b)
            End If
            Td(1, 0) = x
            For i = 2 To NbRw
                Tb(i, 1) = Tb(i - 1, 1) - (Tb(i - 1, 2) = d + 2)
                x = Tb(i, 1)
                For j = 2 To b - 1
                    If Tb(i - 1, j + 1) = d + j + 1 Then
                        If Tb(i - 1, j) = d + j Then Tb(i, j) = Tb(i, j - 1) + 1 Else Tb(i, j) = Tb(i - 1, j) + 1
                    Else
                        Tb(i, j) = Tb(i - 1, j)
                    End If
                    x = x & " " & Tb(i, j)
                Next j
                If Tb(i - 1, b) = a Then Tb(i, b) = Tb(i, b - 1) + 1 Else Tb(i, b) = Tb(i - 1, b) + 1
                Td(i, 0) = x & " " & Tb(i, b)
            Next i
            Cells(1, 1).Resize(NbRw, 1).Offset(0, c).Value = Td
            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 = Columns.Count
        c = 0
    Loop Until NbWrt = 0
    Cells.EntireColumn.AutoFit
    Application.ScreenUpdating = True: Application.Calculation = m
End Sub
Résultat en ~13s, bien que le code en utilise ~5,7.
On retrouve des résultats proches de ceux de mon code, mais avec une procédure beaucoup plus puissante grâce à son paramétrage, même si Excel patauge un peu.

Reste à voir si on peut mieux faire... poil au blair !


ROGER2327
#5614


Samedi 14 Pédale 139 (Sabbat - Vacuation)
18 Ventôse An CCXX, 1,3924h - mouron
2012-W10-4T03:20:30Z
 
Dernière édition:

julien clerc

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

salut pierrot !
oui j'ais tester mais toujour des combinaison à 5 numéros pair ou impair ! voici ma macro de base :

lin = 1
col = 1
For m = 1 To 49
For n = m + 2 To 49
For o = n + 2 To 49
For p = o + 2 To 49
For q = p + 2 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
 

ROGER2327

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

Re...


Il faut vraiment tout faire !

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 And (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
#5615


Samedi 14 Pédale 139 (Sabbat - Vacuation)
18 Ventôse An CCXX, 4,5636h - mouron
2012-W10-4T10:57:09Z
 

KenDev

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

Bonjour à tous,

Le code proposé n'est qu'une mise en vba des formules proposées ici :
https://www.excel-downloads.com/threads/loto.8728/
Avec en plus la gestion des cas ou le nombre de combinaisons dépasse le nombre de lignes d'une feuille et les cas ou la feuille n'a pas assez de colonnes. Ce dernier cas pour le plaisir puisque dans la pratique : pour afficher toutes les combinaisons des tirages type keno par exemple (161884603662657876
combinaisons) il faudrait 197929730 feuilles, personelement je ne m'y risquerais pas...

@Roger.

Merci beaucoup pour vos codes. Je suis très intéréssé par le premier que je vais tacher de décortiquer. Pour le second je part du principe que si j'ai a afficher toutes les combinaisons c'est pour ensuite les exploiter par formule ou vba, ce qui me semble plus pratique avec une case par numéro, (quoique pour le vba 'split' est prévu pour!). Avec affichage, pour 49-4 je passe de 17 à 15 secondes, pour 49-5 je passe de 240 à 197s (soit respectivement -11% et -17%). Plus la quantité augmente plus votre code est efficace.

Après une première lecture :

Je retiens le If Then Else sur une ligne que je trouve très élégant.

Je savais pour les IIf mais bétement j'avais choisi la brieveté du code au détriment de son efficacité. Merci pour le rappel d'utiliser les valeurs true/false. Je note la disparition des Select Cases.

Je n'avais pas typé mes tableaux car après avoir découvert récement que l'on pouvait déclarer un tableau directement sur une plage et vice-versa, j'avais cru comprendre après un test que le typage provoquait une erreur lors de l'affectation. Manifestement ce n'est pas vrai lors de la restitution d'un tableau sur une plage ? Ou bien est ce que c'est votre formulation 'Cells(1, 1).Resize(NbRw, b).Offset(0, c * (b + 1)).Value = Tb' au lieu de 'Rg=Tb' qui permet celà ? Si non quel est l'intéret de cette formulation ?

Je me rend compte avoir mal placé 'Cells.EntireColumn.AutoFit' qui devrait être entre les deux 'Loop'.

Je note enfin l'interdiction de b=1 qui ne posait pas de souci avec les formules mais qui logiquement provoque une erreur dans la procédure. C'est vrai que b=1 est d'un intérêt limité puisqu'il s'agit simplement alors d'afficher les nombres de 1 à a.
Ci dessous votre code avec la correction du placement de l'autofit et l'acceptation de b=1 (deux if b=1 rajoutés et les tableaux passent de integer à long pour pouvoir lancer par exemple 'Call AffComb2(1000000, 1)')

@Julien :
C'est vrai que je ne me suis pas occupé du filtrage demandé. Mais en même temps il n'y a que 42504 combinaisons 'tous pairs' et 53130 'tous impairs' sur un total de 1906884. Ne serait-il pas mieux de réaliser vos divers filtrages après affichage sous forme d'extraction de la base constituée ? Par ailleurs j'ai téléchargé l'historique loto qui ne contient que 536 tirages. Effectivement les 'tous pairs' sont en retard (4 occurances sur 12 attendues) mais les tous impairs en avance (16 occurences sur 15 attendues). Les 'tous pairs' ne vont-ils pas avoir tendance à rattrapper leur retard ?

Cordialement

KD

VB:
Sub AffComb2(a&, b&)
'http://www.excel-downloads.com/forum/179923-code-vba-combinaison-5-numero-sur-49-a-2.html
Dim i&, j&, NbCmb#, Tb&(), NbWrt#, NbRw&, m&, c%, Tc&(), s&, d&
    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)
    d = a - b
    Do
        Sheets.Add: s = s + 1
        Do
            If NbWrt > Rows.Count Then NbRw = Rows.Count Else NbRw = 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
                If b = 1 Then
                    Tb(1, 1) = Tc(1) + 1
                Else
                    Tb(1, 1) = Tc(1) - (Tc(2) = d + 2)
                    For i = 2 To b - 1
                        If Tc(i + 1) = d + i + 1 Then Tb(1, i) = Tc(i + (Tc(i) = d + i)) + 1 Else Tb(1, i) = Tc(i)
                    Next i
                    Tb(1, b) = Tc(b + (Tc(b) = a)) + 1
                End If
            End If
            For i = 2 To NbRw
                If b = 1 Then
                    Tb(i, 1) = Tb(i - 1, 1) + 1
                Else
                    Tb(i, 1) = Tb(i - 1, 1) - (Tb(i - 1, 2) = d + 2)
                    For j = 2 To b - 1
                        If Tb(i - 1, j + 1) = d + j + 1 Then
                            If Tb(i - 1, j) = d + j Then Tb(i, j) = Tb(i, j - 1) + 1 Else Tb(i, j) = Tb(i - 1, j) + 1
                        Else
                            Tb(i, j) = Tb(i - 1, j)
                        End If
                    Next j
                    If Tb(i - 1, b) = a Then Tb(i, b) = Tb(i, b - 1) + 1 Else Tb(i, b) = Tb(i - 1, b) + 1
                End If
            Next i
            Cells(1, 1).Resize(NbRw, b).Offset(0, c * (b + 1)).Value = 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
        Cells.EntireColumn.AutoFit
    Loop Until NbWrt = 0
    Application.ScreenUpdating = True: Application.Calculation = m
End Sub
 
Dernière édition:

Discussions similaires

Réponses
6
Affichages
258

Statistiques des forums

Discussions
311 725
Messages
2 081 943
Membres
101 849
dernier inscrit
florentMIG