Matrice avec toutes les combinaisons de k éléments dans N [Fermé]

Signaler
-
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
-
Bonjour,
je cherche à créer une fonction qui, à partir d'un argument N, me renverra une matrice à N colonnes avec toutes les combinaisons possibles de 0 et 1. Par exemple :

Matrice(3) =
001
010
100
110
101
011
111

J'avoue que je galère depuis plusieurs semaines dessus...
Si quelqu'un pouvait me donner la solution ou la philosophie à considérer pour y parvenir, se serait très appréciable.
En vous remerciant par avance.

9 réponses

Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467
Bonjour,

Je suppose que ton exemple avec 0 et 1 n'est qu'un exemple.
Tu voudras certainement les combinaisons de, par exemple :
Matrice(6) avec 0123
Soit :
000123
001023
010023
100023
002013
etc...
333333
En fait ce que je cherche c'est obtenir une matrice qu'avec des 0 et 1 (que l'on pourrait traduire par false et true). Mais si une fonction permet de faire la même chose avec d'autres chiffres (2, 3 comme dans ton exemple et plus), elle pourrait logiquement en faire de même avec mon cas particulier de 0 et 1.
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467
Je te pose la question car l'algorithme est totalement différent.
Je regarde si je sais faire...ou pas!
Merci beaucoup !
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278
Bonjour
Un essai avec le nombre en B1 (limité à 9)
https://www.cjoint.com/c/FDvn3NZuEGk
A tester
cdlt
Merci beaucoup. J'en reviens pas du nombre de ligne de code ! Je vais regarder ça et tenter de créer une fonction avec si possible avec un nombre d’élément supérieur à 9. Encore merci à vous !
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467
Bonjour Frenchie,

Très bon code utilisant des formules.
J'étais parti dans cette direction, mais tu as été plus rapide.
Alors je propose une alternative.
A tester, mais je pense que les seules limites sont :
> la durée ==> très long après N=9
> la restitution dans une feuille si N > 16 est à modifier
> la puissance du pc...

Le code :

Option Explicit

    Dim Matrice_Finale As Object
    
    Sub test()
    Dim Cle
    
        Call Matrice(4, "0", "1")
        'restitution
        'For Each Cle In Matrice_Finale.Keys
        '    Debug.Print Cle
        'Next
        'limité à N = 16 car 65536 résultats.
        '17 ne passe pas à cause d'Application Transpose
        '[A1].Resize(Matrice_Finale.Count) = Application.Transpose(Matrice_Finale.Keys)
        
        'si séparation des caractères pour affichage sur plusieurs colonnes
        'Dim Eclate, j As Byte, Sortie As String
        'For Each Cle In Matrice_Finale.Keys
        '    Eclate = Split(StrConv(Cle, vbUnicode), Chr(0))
        '    Sortie = ""
        '    For j = 0 To UBound(Eclate) - 1
        '        Sortie = Eclate(j) & "-" & Sortie
        '    Next j
        '    Debug.Print Sortie
        'Next
    End Sub

    Sub Matrice(N As Byte, Digit_1 As String, Digit_2 As String)
    Dim Chaine As String, temp As Variant, i As Long
    
        Chaine = String(N, Digit_1) & String(N, Digit_2)
        Set Matrice_Finale = CreateObject("Scripting.Dictionary")
        For i = 1 To N + 1
            Combiner Mid(Chaine, i, N), ""
        Next i
    End Sub
        
    Sub Combiner(strText As String, debut As String)
    Dim i As Integer
    
        If Len(strText) = 1 Then
            Matrice_Finale(debut & strText) = ""
        Else
            For i = 1 To Len(strText)
                Combiner Mid(strText, 2, Len(strText) - 1), debut & Mid(strText, 1, 1)
                strText = Mid(strText, 2, Len(strText) - 1) & Mid(strText, 1, 1)
            Next
        End If
    End Sub

Je vais regarder ça minutieusement. Encore merci !
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278
Bonsoir
Autre méthode qui traite 20 caractères soit 1048576 combinaisons (l'équivalent d'une colonne pleine d'excel 2007) en 8mn sur mon PC, évidemment pour des quantités demandées plus faible, l'exécution est assez rapide.
Je n'ai pas cherché à vous laissé le choix du nombre de caractères (manque de temps), soit vous le faites vous-même en modifiant le code, soit vous patientez un peu.
https://www.cjoint.com/c/FDvvpQ2vnZw
Cdlt
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278
Bonjour Alexander, bonjour Pijaku
Je pense qu'avec l'aide de quelques dictionnaires(je ne connais pas la taille max d'un dictionnaire),le temps devrait être considérablement réduit.
Je regarderai ça dans la journée, à moins quelqu'un d'ici là fasse une proposition.
Bonne journée
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278
A Pijaku
Bonjour Pijaku
j'ai besoin de vos connaissances, revoici le résultat avec utilisation d'un dictionnaire, mais je n'arrive pas à afficher le résultat, qu'est-ce qui cloche?

Sub Convertir3()
    Application.ScreenUpdating = False
    Dim Cel As Variant
    Columns(1).ClearContents
    Temps = Timer
    Set Dico = CreateObject("Scripting.Dictionary")
    For A = 0 To 1
     For B = 0 To 1
      For C = 0 To 1
       For D = 0 To 1
        For E = 0 To 1
         For F = 0 To 1
          For G = 0 To 1
           For H = 0 To 1
            For I = 0 To 1
             For J = 0 To 1
              For K = 0 To 1
               For L = 0 To 1
                For M = 0 To 1
                 For N = 0 To 1
                  For O = 0 To 1
                   For P = 0 To 1
                    For Q = 0 To 1
                     For R = 0 To 1
                      For S = 0 To 1
                       For T = 0 To 1
                        x = A & B & C & D & E & F & G & H & I & J & K & L & M & N & O & P & Q & R & S & T
                        Dico.Add x, ""
                       Next T
                      Next S
                     Next R
                    Next Q
                   Next P
                  Next O
                 Next N
                Next M
               Next L
              Next K
             Next J
            Next I
           Next H
          Next G
         Next F
        Next E
       Next D
      Next C
     Next B
    Next A
   [A1].Resize(Dico.Count, 1) = Application.Transpose(Dico.keys)
   MsgBox Timer - Temps & " secondes"
End Sub


merci
Salutations
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467 >
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020

Salut Frenchie83,

La fonction Transpose de VBA n'est en fait que la WorksheetFunction Transpose.
Elle est restée au format xl2003 au passage à Xl2007. D'ou un nombre de lignes limité à 65536. Au delà, ça plante.
Il te faut, pour transposer tes infos, passer par une boucle.
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278
Pijaku un grand merci
Toujours de bon conseil, mais c'est vraiment dommage de devoir repasser par une boucle, on perd le bénéfice obtenu par l'utilisation du dictionnaire.
Avec mon PC de bureau qui n'est pas des plus rapides, j'arrive tout de même à un temps supérieur à 5mn pour le remplissage de la colonne entière, ce qui est tout de même acceptable.
https://www.cjoint.com/c/FDwgDo2eg3l
Encore merci pour le coup de main
Bonne journée
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467
De rien.
Je suis en train de regarder un code pour réduire les lenteurs de ta boucle.
Patiente encore un peu.

Par contre, juste comme ça, sur le forum Programmation en général, il est préférable de mettre les codes directement en réponse, comme tu l'as fait plus haut.
Les fichiers joints ne sont, en effet, pas éternels...
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467
Et voilà.
Ton code, légèrement modifié, s'exécute en 15 secondes :

        Sub Convertir3()
        Application.ScreenUpdating = False
        Dim TB(1 To 1048576, 1 To 1) As Variant, Cpt As Long
        Columns(1).ClearContents
        Temps = Timer
        For A = 0 To 1
         For B = 0 To 1
          For C = 0 To 1
           For D = 0 To 1
            For E = 0 To 1
             For F = 0 To 1
              For G = 0 To 1
               For H = 0 To 1
                For i = 0 To 1
                 For j = 0 To 1
                  For K = 0 To 1
                   For L = 0 To 1
                    For M = 0 To 1
                     For N = 0 To 1
                      For O = 0 To 1
                       For P = 0 To 1
                        For Q = 0 To 1
                         For R = 0 To 1
                          For S = 0 To 1
                           For t = 0 To 1
                           Cpt = Cpt + 1
                           TB(Cpt, 1) = A & B & C & D & E & F & G & H & i & j & K & L & M & N & O & P & Q & R & S & t
                           Next t
                          Next S
                         Next R
                        Next Q
                       Next P
                      Next O
                     Next N
                    Next M
                   Next L
                  Next K
                 Next j
                Next i
               Next H
              Next G
             Next F
            Next E
           Next D
          Next C
         Next B
        Next A
       [A1].Resize(UBound(TB, 1), 1) = TB
       Debug.Print Timer - Temps & " secondes"
    End Sub


Ne te reste plus qu'à en faire une fonction qui accepte le nombre de chiffres en paramètre...
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278 >
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020

Excellent,
l'idée du dictionnaire à été abandonnée au profit d'un tableau, ce qui permet de ne plus avoir le problème de la transposition.
Sur mon PC du bureau, il met 2mn30s, mais comme je l'ai déjà dit , ce n'est pas une fusée. Je testerai ce soir sur mon PC perso beaucoup plus rapide.
Encore bravo et merci
Bonjour et un grand merci à vous 2 ! Vous avez développé en quelques heures ce que je n'ai pas réussis à faire en plusieurs semaines. J'espère que vous êtes des développeurs, cela me fera moins complexer... Je vais regarder vos codes avec attention (et tenter de comprendre ce qu'est un dictionnaire en VBA).
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278
Bonjour Alexander, Bonjour Pijaku
Voici avec le choix du nombre d'éléments, j'ai fait au plus simple.
https://www.cjoint.com/c/FDxjeLfWtsw

A Pijaku: Je n'arrive pas à obtenir le temps de 15 secondes pour 20 chiffres, pourtant j'ai un microprocesseur 4 coeurs. Je reste dans les temps de 4mn.
j'ai appliqué un format autre que texte à la colonne 1, mais suivant les cas, à partir de la ligne 32679, ça ne colle plus. J'ai donc forcé le format à texte en début de code.
Bonne journée
Bonjour. Encore merci. je vais regarder ça et transformer en fonction. Bonne journée.
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467 > Alexander
Bonjour,

@ Frenchie : il faudrait, en amélioration, prévoir :
> une sortie à chaque boucle For pour éviter d'en faire 20 lorsque 7 suffisent
> L'utilisation de Right te permettrai de zapper le Select Case :
Tb(Cpt, 1) = Right(A&B&C&...&S&T, Nb)
Messages postés
2102
Date d'inscription
lundi 6 mai 2013
Statut
Membre
Dernière intervention
4 août 2020
278
Bonjour Alexander, Bonjour Pijaku
A Pijaku:
une sortie à chaque boucle For pour éviter d'en faire 20 lorsque 7 suffisent , c'était prévu avec la ligne suivante
If [B1] < 20 And TB(Cpt, 1) = Valeur Then GoTo Restitution

Malheureusement pour améliorer la présentation du code, j'ai malencontreusement supprimer la ligne suivante:
Valeur = Application.WorksheetFunction.Rept(1, [B1])
ce qui évidemment l'obligeait à traiter les 20 cas, vu qu'il ne trouvait jamais la variable "valeur".
Voici la correction avec la suppression des select case, ce qui fait plus pro.

Sub Convertir()
    Application.ScreenUpdating = False
    Dim TB(1 To 1048576, 1 To 1) As Variant, Cpt As Long
    If [B1] < 2 Or [B1] > 20 Or [B1] = "" Or Not IsNumeric([B1]) Then Exit Sub
    Valeur = Application.WorksheetFunction.Rept(1, [B1])
    Columns("A:A").NumberFormat = "@"
    Columns(1).ClearContents
    Temps = Timer
    For A = 0 To 1
     For B = 0 To 1
      For C = 0 To 1
       For D = 0 To 1
        For E = 0 To 1
         For F = 0 To 1
          For G = 0 To 1
           For H = 0 To 1
            For i = 0 To 1
             For J = 0 To 1
              For K = 0 To 1
               For L = 0 To 1
                For M = 0 To 1
                 For N = 0 To 1
                  For O = 0 To 1
                   For P = 0 To 1
                    For Q = 0 To 1
                     For R = 0 To 1
                      For S = 0 To 1
                       For T = 0 To 1
                        Cpt = Cpt + 1
                        TB(Cpt, 1) = Right(A & B & C & D & E & F & G & H & i & J & K & L & M & N & O & P & Q & R & S & T, [B1])
                        If [B1] < 20 And TB(Cpt, 1) = Valeur Then GoTo Restitution
                       Next T
                      Next S
                     Next R
                    Next Q
                   Next P
                  Next O
                 Next N
                Next M
               Next L
              Next K
             Next J
            Next i
           Next H
          Next G
         Next F
        Next E
       Next D
      Next C
     Next B
    Next A
    
Restitution:
    [A1].Resize(UBound(TB, 1), 1) = TB
    MsgBox Timer - Temps & " secondes"
End Sub

Encore merci Pijaku et bonne journée à tout les deux
Cordialement
Messages postés
12184
Date d'inscription
jeudi 15 mai 2008
Statut
Modérateur
Dernière intervention
31 juillet 2020
2 467
Allez, juste pour chipoter, deux-trois modifs de ton code :

Sub Convertir()
    Dim TB() As Variant, Cpt As Long, Nb As Byte
    Dim A As Byte, B As Byte, C As Byte, D As Byte, E As Byte, F As Byte
    Dim G As Byte, H As Byte, I As Byte, J As Byte, K As Byte, L As Byte
    Dim M As Byte, N As Byte, O As Byte, P As Byte, Q As Byte, R As Byte
    Dim S As Byte, T As Byte, LB As Long
    
    Application.ScreenUpdating = False
    
    On Error Resume Next
    Nb = [B1]
    On Error GoTo 0
    If Nb < 2 Or Nb > 20 Or Nb = 0 Then Exit Sub
    
    LB = Application.WorksheetFunction.Power(2, Nb)
    ReDim Preserve TB(1 To LB, 1 To 1)
    
    Valeur = Application.WorksheetFunction.Rept(1, Nb)
    Columns("A:A").NumberFormat = "@"
    Columns(1).ClearContents
    Temps = Timer
    
    For A = 0 To 1
     For B = 0 To 1
      For C = 0 To 1
       For D = 0 To 1
        For E = 0 To 1
         For F = 0 To 1
          For G = 0 To 1
           For H = 0 To 1
            For I = 0 To 1
             For J = 0 To 1
              For K = 0 To 1
               For L = 0 To 1
                For M = 0 To 1
                 For N = 0 To 1
                  For O = 0 To 1
                   For P = 0 To 1
                    For Q = 0 To 1
                     For R = 0 To 1
                      For S = 0 To 1
                       For T = 0 To 1
                        Cpt = Cpt + 1
                        TB(Cpt, 1) = Right(A & B & C & D & E & F & G & H & I & J & K & L & M & N & O & P & Q & R & S & T, Nb)
                        If Nb < 20 And TB(Cpt, 1) = Valeur Then GoTo Restitution
                       Next T
                      Next S
                     Next R
                    Next Q
                   Next P
                  Next O
                 Next N
                Next M
               Next L
              Next K
             Next J
            Next I
           Next H
          Next G
         Next F
        Next E
       Next D
      Next C
     Next B
    Next A
    
Restitution:
    [A1].Resize(UBound(TB, 1), 1) = TB
    MsgBox Timer - Temps & " secondes"
End Sub