Macro de combinaisons

JJ1 · 27 Mars 2009

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

suistrop · 27 Mars 2009

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

CBernardT · 27 Mars 2009

Re : Macro de combinaisons

Bonsoir JJ1, suistrop et le forum,

Une macro qui Liste les combinaisons présentes dans la plage et le nombre de fois qu'elles sont présentes.

Cordialement

Bernard

suistrop · 28 Mars 2009

Re : Macro de combinaisons

hello Bernard,

Je trouve pas les memes reponses , jvois pas mon eventuelle erreur ...

ROGER2327 · 28 Mars 2009

Re : Macro de combinaisons

Bonsoir à tous

Tout cela me parait bien compliqué et trop lent. Et pourquoi se priver de toutes les réponses ? Voyez ce classeur : votre avis m'intéresse.

Bonne nuit !
ROGER2327

JJ1 · 28 Mars 2009

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é.

ROGER2327 · 28 Mars 2009

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)

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

ROGER2327 · 28 Mars 2009

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

suistrop · 28 Mars 2009

Re : Macro de combinaisons

Salut,

Pour faire plus rapide , je pensais a regarde chaque ligne du truc et sortir toute les combi possible en fct des 20 nombre mais je sais pas automatiser comment automatiser cela :/

CBernardT · 28 Mars 2009

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

job75 · 28 Mars 2009

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+

JJ1 · 28 Mars 2009

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.

JJ1 · 28 Mars 2009

Re : Macro de combinaisons

Je joins un bout d'exemple, avec, par ex, la macro de Job75.
Il y a une case NB (nb de combinaisons) et Ligne rajoutée.
Bonne soirée

ROGER2327 · 28 Mars 2009

Re : Macro de combinaisons

Bonjour à tous

ATTENTION : je viens de corriger le code de ce matin. Les corrections sont à la fin, en rouge.

Avec mes excuses,
ROGER2327

job75 · 28 Mars 2009

Re : Macro de combinaisons

Re JJ1,

Pour ta dernière demande, j'ai presque fini, mais je sors ce soir. Je terminerai demain matin.

A+

Macro de combinaisons

JJ1

Guest

Pièces jointes

suistrop

XLDnaute Impliqué

CBernardT

XLDnaute Barbatruc

Pièces jointes

suistrop

XLDnaute Impliqué

Pièces jointes

ROGER2327

XLDnaute Barbatruc

Pièces jointes

JJ1

Guest

ROGER2327

XLDnaute Barbatruc

ROGER2327

XLDnaute Barbatruc

suistrop

XLDnaute Impliqué

CBernardT

XLDnaute Barbatruc

Pièces jointes

job75

XLDnaute Barbatruc

Pièces jointes

JJ1

Guest

JJ1

Guest

Pièces jointes

ROGER2327

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Discussions similaires

Macro de combinaisons

JJ1

Guest

Pièces jointes

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Impliqué

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

JJ1

Guest

XLDnaute Barbatruc

XLDnaute Barbatruc

XLDnaute Impliqué

XLDnaute Barbatruc

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

JJ1

Guest

JJ1

Guest

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Discussions similaires

Privacy & Transparency

Privacy & Transparency