XL 2013 Générer des combinaisons

lmontagne31

XLDnaute Nouveau
Bonjour à tous,

j'ai un tableau qui est du style
1623361047141.png


et j'aimerai générer une liste de toutes les combinaison sachant que je ne peux avoir qu'une case renseignée par ligne.


1623361224400.png

...

2 jour que je cherche l'algorithme mais impossible.
Pouvez vous m'aider SVP.
Merci


1623361023225.png
 

Pièces jointes

  • test.xlsx
    8.4 KB · Affichages: 9

Softmama

XLDnaute Accro
Bonjour lmontagne31, dysorthographie,

Une réponse dans le fichier joint.
Pour moi, si j'ai bien compris la problématique, il y a 625 - 1 combinaisons : 5 par ligne sur 4 lignes, soient 5*5*5*5 - 1 car le code 0000 (aucune croix est à éliminer) :

VB:
Sub test()
Dim Table(), n As Integer
ReDim Table(1 To 1, 1 To 1)
 For t = 0 To 4 'Activities1 : 0 pas de croix, 1= Croix en S, 2=Croix en M, 3= croix en V, 4=Croix en VC
   For u = 0 To 4 'Activities2... pareil
     For v = 0 To 4 'Activities3... pareil
       For w = 0 To 4 'Activities4... pareil
         n = n + 1
         ReDim Preserve Table(1 To 1, 1 To n)
         Table(1, n) = "'" & t & u & v & w 'Code
       Next
     Next
   Next
 Next
 Feuil1.Range("A10").Resize(UBound(Table, 2), 1) = Application.Transpose(Table) 'Liste de toutes les combinaisons
End Sub
Le détail dans le fichier.
 

Pièces jointes

  • test (1).xlsm
    27 KB · Affichages: 2

Softmama

XLDnaute Accro
re bonjour le fil,

Pour répondre plus précisément à votre demande, je fais afficher dans cette version mise à jour, les 625 combinaisons, non plus sous la forme d'un code, mais avec les croix dans les cases, comme demandé :

VB:
Sub test()
Dim c As Range

Application.ScreeUpdating = False
For t = 0 To 4
  For u = 0 To 4
    For v = 0 To 4
      For w = 0 To 4
        If t+u+v+w <> 0 Then 'Pour éviter aucune croix
          Set c = Feuil2.Range("A1000000").End(xlUp).Offset(2)
          Feuil2.Range("A2:F6").Copy c
          c.Offset(1, 5) = t
          c.Offset(2, 5) = u
          c.Offset(3, 5) = v
          c.Offset(4, 5) = w
        End If
      Next
    Next
  Next
Next
Application.ScreeUpdating = True

End Sub

Attention, l'ensemble des 625 tableaux occupe 3500 lignes environ.
cf. fichier joint
 

Pièces jointes

  • test (1).xlsm
    21.3 KB · Affichages: 5

lmontagne31

XLDnaute Nouveau
re bonjour le fil,

Pour répondre plus précisément à votre demande, je fais afficher dans cette version mise à jour, les 625 combinaisons, non plus sous la forme d'un code, mais avec les croix dans les cases, comme demandé :

VB:
Sub test()
Dim c As Range

Application.ScreeUpdating = False
For t = 0 To 4
  For u = 0 To 4
    For v = 0 To 4
      For w = 0 To 4
        If t+u+v+w <> 0 Then 'Pour éviter aucune croix
          Set c = Feuil2.Range("A1000000").End(xlUp).Offset(2)
          Feuil2.Range("A2:F6").Copy c
          c.Offset(1, 5) = t
          c.Offset(2, 5) = u
          c.Offset(3, 5) = v
          c.Offset(4, 5) = w
        End If
      Next
    Next
  Next
Next
Application.ScreeUpdating = True

End Sub

Attention, l'ensemble des 625 tableaux occupe 3500 lignes environ.
cf. fichier joint
Merci beaucoup c'est exactement ce dont j'avais besoin. :)
 

Discussions similaires