Macro de combinaisons

Créer une discussion
Répondre
  • Initiateur de la discussion Initiateur de la discussion JJ1
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

S'inscrire
J

JJ1

Guest
Bonsoir à tous,

Je souhaiterais votre aide pour une macro qui fait deux actions:
-elle crée des combinaisons de 5 nombres à partir de 20 nombres donnés en ligne 2: A2:T2

- vu le nombre important de combinaisons crées (environ 10000), elle ne les affiche pas, mais fait un comptage et inscrit en plage U2:Y13 uniquement celles qui sont le plus présentes dans une plage de réference (ici AA2:AT17).

Ce fichier est actuellement fait (avec des combinaisons de 4 nombres) par des formules et est très lourd mais surtout très très long à calculer!

Je pense qu'une macro irait beaucoup plus vite (et je peux ainsi passer à 5 nombres).

Bonne soirée

Important: ne pas tenir compte de ce post pour le moment, trop de combinaisons à gérer(j'ai calculé:15500 !!), je modifierai le fichier joint .
merci
 

Pièces jointes

Dernière modification par un modérateur:
Trier par date Trier par votes
Re : Macro de combinaisons

marrant ton truc ,

pour faire remplir un tableau sous vba avec tout les codes je fais ca :
Code: 
Sub toto()
'dans un premier temps on va faire toutes les combinaisons possible que l'on va mettre dans 1 tableau
Dim tab_nombre(19)
For i = 0 To 19
    tab_nombre(i) = Cells(2, i + 1)
Next i

Dim tab_toto(10000000, 4)

cpt = 0
cpt = 0
    For nb_0 = 0 To 15
        For nb_1 = 1 To 16
            For nb_2 = 2 To 17
                For nb_3 = 3 To 18
                    For nb_4 = 4 To 19
                        tab_toto(cpt, 0) = tab_nombre(nb_0)
                        tab_toto(cpt, 1) = tab_nombre(nb_1)
                        tab_toto(cpt, 2) = tab_nombre(nb_2)
                        tab_toto(cpt, 3) = tab_nombre(nb_3)
                        tab_toto(cpt, 4) = tab_nombre(nb_4)
                        cpt = cpt + 1
                    Next nb_4
                Next nb_3
            Next nb_2
        Next nb_1
    Next nb_0


End Sub
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Macro de combinaisons

Bonjour à tous et félicitations pour ce travail.

Toutes les macros fonctionnent, celle de Roger est plus rapide à donner le résultat.(je n'ai pas détaillé son code)

J'avais abandonné le projet, mais devant les possibilités d'Excel (vitesse de la macro étonnante par rapport aux formules, notamment sommeprod/fréquence, qui me limitait à 4 nombres), j'en rajoute : est-il possible de rajouter des lignes à la macro pour faire à 6 nombres (au lieu de combinaisons de 5)?
Je verrai la vitesse d'exécution?
Si c'est trop long à modifier, on laisse tel quel.
Merci à vous et Bravo !
Bon samedi

ps: je pense que ces macros sont à conserver dans XLD, car ce sujet de combinaison/permutation est très demandé.
 
Vote positif 0 Vote négatif
Re : Macro de combinaisons

Bonjour JJ1
Il est tout à fait possible de
rajouter des lignes à la macro pour faire à 6 nombres (au lieu de combinaisons de 5)
Cliquez pour agrandir...
Voilà le code :
Code: 
Sub calcul6()
[COLOR="SeaGreen"]'ROGER2327 fecit. 8 Germinal CCXVII.[/COLOR]
Dim oDat(), oCpt(), oSrt(1 To 38760, 1 To 7), oCel
Dim y As Long, z As Long, h As Long, i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
    With ActiveSheet
        Application.Calculation = xlCalculationManual
        .Range("C6:I38760").ClearContents
        Application.ScreenUpdating = False
        oDat = .Range("A2:T2").Value
        For Each oCel In .Range("AA2:AT17")
            For i = 1 To 20
                If oCel = oDat(1, i) Then y = y + 1: ReDim Preserve oCpt(1 To y): oCpt(y) = oCel: Exit For
            Next i
        Next oCel
        For h = 1 To 15
            For i = h + 1 To 16
                For j = i + 1 To 17
                    For k = j + 1 To 18
                        For l = k + 1 To 19
                            For m = l + 1 To 20
                                z = z + 1
                                oSrt(z, 1) = oDat(1, h)
                                oSrt(z, 2) = oDat(1, i)
                                oSrt(z, 3) = oDat(1, j)
                                oSrt(z, 4) = oDat(1, k)
                                oSrt(z, 5) = oDat(1, l)
                                oSrt(z, 6) = oDat(1, m)
                                oSrt(z, 7) = 0
                                n = 1
                                Do
                                    For n = n To y
                                        If oDat(1, h) = oCpt(n) Then Exit For
                                    Next n
                                    If n < y Then
                                        For n = n To y
                                            If oDat(1, i) = oCpt(n) Then Exit For
                                        Next n
                                        If n < y Then
                                            For n = n To y
                                                If oDat(1, j) = oCpt(n) Then Exit For
                                            Next n
                                            If n < y Then
                                                For n = n To y
                                                    If oDat(1, k) = oCpt(n) Then Exit For
                                                Next n
                                                If n < y Then
                                                    For n = n To y
                                                        If oDat(1, l) = oCpt(n) Then Exit For
                                                    Next n
                                                    If n < y Then
                                                        For n = n To y
                                                            If oDat(1, m) = oCpt(n) Then Exit For
                                                        Next n
                                                        If n <= y Then oSrt(z, 7) = oSrt(z, 7) + 1
                                                    End If
                                                End If
                                            End If
                                        End If
                                    End If
                                Loop While n <= y
                            Next m
                        Next l
                    Next k
                Next j
            Next i
        Next h
        .Range("[COLOR="Red"][B]C6:I38765[/B][/COLOR]").Value = oSrt
        .Range("[COLOR="Red"][B]C6:I38765[/B][/COLOR]").Sort Key1:=Range("I6"), Order1:=xlDescending, Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
C'est rapide (quelques secondes).​
Bonne journée !
ROGER2327
 
Dernière édition:
Vote positif 0 Vote négatif
Re : Macro de combinaisons

Re...
J'ai corrigé quelques détails qui font que le code pour cinq nombres donné hier devient :
Code: 
Sub calcul()
[COLOR="SeaGreen"]'ROGER2327 fecit. 7 Germinal CCXVII.[/COLOR]
Dim oDat(), oCpt(), oSrt(1 To 15504, 1 To 6), oCel
Dim y As Long, z As Long, i As Long, j As Long, k As Long, l As Long, m As Long, n As Long
    With ActiveSheet
        Application.Calculation = xlCalculationManual
        .Range("D6:I15509").ClearContents
        Application.ScreenUpdating = False
        oDat = .Range("A2:T2").Value
        For Each oCel In .Range("AA2:AT17")
            For i = 1 To 20
                If oCel = oDat(1, i) Then y = y + 1: ReDim Preserve oCpt(1 To y): oCpt(y) = oCel: Exit For
            Next i
        Next oCel
        For i = 1 To 16
            For j = i + 1 To 17
                For k = j + 1 To 18
                    For l = k + 1 To 19
                        For m = l + 1 To 20
                            z = z + 1
                            oSrt(z, 1) = oDat(1, i)
                            oSrt(z, 2) = oDat(1, j)
                            oSrt(z, 3) = oDat(1, k)
                            oSrt(z, 4) = oDat(1, l)
                            oSrt(z, 5) = oDat(1, m)
                            oSrt(z, 6) = 0
                            n = 1
                            Do
                                For n = n To y
                                    If oDat(1, i) = oCpt(n) Then Exit For
                                Next n
                                If n [B][COLOR="Red"]<[/COLOR][/B] y Then
                                    For n = n To y
                                        If oDat(1, j) = oCpt(n) Then Exit For
                                    Next n
                                    If n [B][COLOR="Red"]<[/COLOR][/B] y Then
                                        For n = n To y
                                            If oDat(1, k) = oCpt(n) Then Exit For
                                        Next n
                                        If n [B][COLOR="Red"]<[/COLOR][/B] y Then
                                            For n = n To y
                                                If oDat(1, l) = oCpt(n) Then Exit For
                                            Next n
                                            If n [B][COLOR="Red"]<[/COLOR][/B] y Then
                                                For n = n To y
                                                    If oDat(1, m) = oCpt(n) Then Exit For
                                                Next n
                                                If n <= y Then oSrt(z, 6) = oSrt(z, 6) + 1
                                            End If
                                        End If
                                    End If
                                End If
                            Loop While n <= y
                        Next m
                    Next l
                Next k
            Next j
        Next i
        .Range("D6:I15509").Value = oSrt
        .Range("D6:I15509").Sort Key1:=Range("I6"), Order1:=xlDescending, Header:=xlNo, OrderCustom:=1, _
            MatchCase:=False, Orientation:=xlTopToBottom, DataOption1:=xlSortNormal
    End With
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
End Sub
ROGER2327
 
Vote positif 0 Vote négatif
Re : Macro de combinaisons

Bonjour JJ1, suistrop, ROGER2327 et le forum,

Une macro améliorée qui va plus vite (10s sur mon ordi) et qui Liste les arrangements par six nombres présents dans les lignes de la plage et le nombre de fois qu'ils sont présents.

Cordialement

Bernard
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Macro de combinaisons

Bonjour le fil, le forum,

Ce fil est intéressant, et j'y vais donc de ma solution.

La détermination des combinaisons est quasi immédiate avec des tableaux.

Leur affichage prend un peu plus de temps.

Voir le fichier joint avec les 2 macros pour 5 et 6 nombres par combinaison.

La macro avec 5 nombres :

Code: 
Sub Combinaisons_5_nombres()
Dim tablo(19), i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, _
t1(65532), t2(65532), t3(65532), t4(65532), t5(65532), x As Integer
Call RAZ

For i = 0 To 19
tablo(i) = Cells(2, i + 1)
Next

For i = 0 To 15
  For j = i + 1 To 16
    For k = j + 1 To 17
      For l = k + 1 To 18
        For m = l + 1 To 19
          t1(x) = tablo(i)
          t2(x) = tablo(j)
          t3(x) = tablo(k)
          t4(x) = tablo(l)
          t5(x) = tablo(m)
          x = x + 1
        Next
      Next
    Next
  Next
Next

MsgBox "Nombre de combinaisons : " & x
Application.ScreenUpdating = False
Range("A4:A" & x + 3).Value = Application.Transpose(t1)
Range("B4:B" & x + 3).Value = Application.Transpose(t2)
Range("C4:C" & x + 3).Value = Application.Transpose(t3)
Range("D4:D" & x + 3).Value = Application.Transpose(t4)
Range("E4:E" & x + 3).Value = Application.Transpose(t5)

End Sub

A+
 

Pièces jointes

Vote positif 0 Vote négatif
Re : Macro de combinaisons

Bonjour (ou rebonjour) à tous et merci.

Excel a des possibilités combinatoires impressionnantes (6 nombres en quelques secondes !)
Pour l'instant, j'en reste à des combinaisons de 5 (avant je n'étais qu'à 4)

J'ai un problème paradoxal:
la macro va très très vite et une formule dans mon tableau me prend environ .......30minutes pour les 15000 combinaisons !
Dommage, cette formule (de Gaël, merci à lui, de forme (ne pas tenir compte des plages):

={EQUIV(1;(FREQUENCE(SI(NB.SI(K1:O1;$A$1:$J$9)=0;"";NB.SI(K1:O1;$A$1:$J$9)*LIGNE($A$1:$J$9));LIGNE($A$1:$J$10)-1)>=5)*1;0)-1}

me permet de récupérer à côté du nombre de chaque combinaison, le numéro de ligne où cette combinaison apparaît pour la première fois (écart de ligne à partir du haut de tableau de comptage) dans le tableau de comptage.

J'ai donc voulu ajouter à votre macro de combinaison, la macro qu'avait faite PierreJean dans le sujet "Récupération du numéro de ligne" en page 2 XLD.

J'avoue que mon résultat n'est pas à la hauteur du vôtre....si vous avez un moment pour l'y rajouter.

merci à vous et bonne soirée

PS: pour l'affichage de toutes les macros, merci d'afficher les 15000 combinaisons (et pas seulement les plus présentes), car ça me permet de faire un Données/tri/sous total ensuite.
 
Vote positif 0 Vote négatif
Rejoins nos membres "Supporter XLD" et booste ton expérience Excel !
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD
Assurez vous de marquer un message comme solution pour une meilleure transparence.

Discussions similaires

Mathmath06
  • Question Question
XL 2016 Calcul écart de combinaison de 4 numéros Keno
2
Réponses
17
Affichages
3 K
dysorthographie
dysorthographie
W
  • Question Question
XL 2021 Double boucle
Réponses
2
Affichages
534
whiteshark
W
G
  • Question Question
Microsoft 365 Réduire la taille de la macro ?
Réponses
9
Affichages
1 K
Staple1600
Staple1600
M
  • Résolu(e)
Microsoft 365 [Résolu] Macro extraction de dates
Réponses
6
Affichages
1 K
maxime45
M
B
  • Résolu(e)
XL 2010 Suite de Fibonacci
Réponses
4
Affichages
2 K
Bicycle74
B
C
  • Question Question
XL 2016 Macro affiche ### comme résultat de calcul des couleurs
Réponses
1
Affichages
626
job75
job75
N
  • Question Question
XL 2010 Copier dernière ligne / mise en forme spécifique + optimisation de macro
Réponses
11
Affichages
2 K
NathalieQSE
N
C
  • Question Question
Microsoft 365 problème navigation et selection dans Combobox-Liste de choix
Réponses
4
Affichages
2 K
chostra
C
B
  • Question Question
XL 2013 [VBA] Extraction de données basé sur 2 à 3 conditions
Réponses
2
Affichages
2 K
bastienb
B
N
  • Résolu(e)
XL 2016 Lenteur à l'insertion de ligne en VBA
Réponses
5
Affichages
3 K
Nicocotte125
N
P
  • Question Question
XL 2019 VBA - Déclencher la macro sur toutes les lignes
Réponses
3
Affichages
1 K
Pheine
P
C
  • Question Question
XL 2016 Formule ou macro ? Besoin de votre expertise !
Réponses
12
Affichages
2 K
calvinethobbes
C
G
  • Question Question
XL 2016 macro de triage
Réponses
1
Affichages
917
grodep
G
L
  • Question Question
XL 2013 Macro pour trouver une combinaison de 6 numéros et plus qui a sortie le plus souvent
Réponses
0
Affichages
1 K
Lucko
L
M
  • Question Question
Nombre de combinaisons possibles
Réponses
4
Affichages
3 K
mat3692
M
A
  • Question Question
XL 2013 Avancement de commande par macro
Réponses
9
Affichages
992
CPk
C
P
  • Question Question
VBA Sommer des nombres de différentes couleurs
Réponses
6
Affichages
2 K
Paf
Paf
J
  • Question Question
Masquer colonne en fonction de 2 dates
Réponses
14
Affichages
2 K
CPk
C
D
  • Question Question
Importer les données d'une plage en fonction des en-tete de colonne avec RechercheV
Réponses
1
Affichages
1 K
Paritec
Paritec
M
  • Question Question
Macro repeter tant que en codage VBA
Réponses
3
Affichages
2 K
Dranreb
Dranreb
Retour