Discussion :

[informer]

Bonjour,


Je dois à partir d'une liste arranger 2 par 2 chaque item sans jamais avoir un arrangement avec 2 mêmes items

Exemple
Toto
Titi
Yoyo

Après traitement
Toto -> Titi
Titi -> yoyo
Yoyo -> Toto

J'ai codé cette routine

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
Sub TriColonneAleatoire()
 
 Dim Cell As Range
    Dim Tableau()
    Dim  i As Integer, j As Integer, k As Integer
    Dim idx as long   
 
    idx = Range("A65536").End(xlUp).Row
 
    ReDim Tableau(idx)
    Range("B1:B" & idx).ClearContents
    For Each Cell In Range("A1:A" & idx)
        Tableau(Cell.Row) = Cell
    Next Cell
 
    i = 1
    Do While idx > 2
 
        Randomize
        n = 0
        Do
            idxAlea = WorksheetFunction.RandBetween(1, idx)
            'n = n + 1
            'If n = 100 Then Exit Do
        Loop While Cells(i, 1) = Tableau(idxAlea)
 
        Cells(i, 2) = Tableau(idxAlea)
 
        'Supprime la lignes tirée aléatoirement.
        For j = 1 To UBound(Tableau) - 1
            k = 0
            If j >= idxAlea Then k = 1
            Tableau(j) = Tableau(j + k)
        Next j
 
        ReDim Preserve Tableau(idx - 1)
        idx = UBound(Tableau)
 
        i = i + 1
    Loop
 
    If Cells(i, 1).Value = Tableau(1) Or Cells(i + 1, 1).Value = Tableau(2) Then
        Cells(i, 2).Value = Tableau(2)
        Cells(i + 1, 2).Value = Tableau(1)
    Else
        Cells(i, 2).Value = Tableau(1)
        Cells(i + 1, 2).Value = Tableau(2)
 
    End If  
 
End Sub

Ca fonctionne mais je ne suis pas content de la verrue

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
   If Cells(i, 1).Value = Tableau(1) Or Cells(i + 1, 1).Value = Tableau(2) Then
        Cells(i, 2).Value = Tableau(2)
        Cells(i + 1, 2).Value = Tableau(1)
    Else
        Cells(i, 2).Value = Tableau(1)
        Cells(i + 1, 2).Value = Tableau(2)
 
    End If

Car si je code

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

 Do While idx > 0

L'arrangement pour le dernier item peut être ItemX -> Item X

Toute idée pour rendre le code propre est la bienvenue

[a_diard]

PS : je ne comprend pas pourquoi tu veux coder

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Do While idx > 0

ton code ne fonctionne qu'avec 2 lignes.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

Do While idx > 2

le code me semble propre et la "verrue" nécessaire.

[Marc-L]

Bonjour !

Sur la base d'un code récupéré sur un forum (pardon de ne pas citer son auteur )

Très mauvais choix de Copier / Coller ‼   C'est souvent le cas sans mener à bien une réflexion !
Déjà rien que la ligne de code n°8 si version Excel > 2003 …

Toute idée pour rendre le code propre est la bienvenue

Perte de temps, c'est bien plus rapide de partir de zéro en respectant la Logique, ce code va direct à la poubelle ‼

Exemple pourtant déjà présenté sur ce forum :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Sub Demo()
            Randomize
    With [A1].CurrentRegion.Columns(1)
            VA = .Value
        For N& = UBound(VA) To UBound(VA) / 2 Step -1
            P& = Fix(Rnd * (N - 1)) + 1
            VP = VA(P, 1):  VA(P, 1) = VA(N, 1):  VA(N, 1) = VP
        Next
            .Offset(, 1).Value = VA
    End With
End Sub

Tout étant déjà dans l'aide VBA interne et dans les tutoriels de ce forum …

___________________________________________________________________________________________________________

     Merci de cliquer sur en bas à droite de chaque message ayant aidé puis sur pour clore cette discussion …

___________________________________________________________________________________________________________

Je suis Paris, Egypte, Nigeria, New-York, Mogadicio, Barcelone, London, Manchester, Stockholm, Istanbul, Berlin, Nice, Bruxelles, Charlie, …

[unparia]

Bonsoir Mar-L

Très mauvais choix de Copier / Coller ‼ C'est souvent le cas sans mener à bien une réflexion !
.....
.....
Perte de temps, c'est bien plus rapide de partir de zéro en respectant la Logique, ce code va direct à la poubelle ‼

Voilà qui me mets en joie et d'excellente humeur.
On ne le dira jamais suffisamment.
Toute autre "approche" est tout, sauf du développement, de la création, etc ...
Merci mille fois de l'avoir dit !

[Marc-L]

Salut Jacques et merci de ton retour !

Ces Copier / Coller d'autres forums sont vraiment agaçants, n'ont rien à faire ici
et si question il y a, autant la poser sur le forum d'origine !

D'habitude je passe mon chemin mais vu les exemples pourtant déjà présents sur ce forum …
Si vraiment il y a eu une tentative de la part du demandeur,
son effort se portera alors sur la compréhension de la simple logique de la démonstration fournie,
devant lui rappeler ses années estudiantines !

Et s'il commet un bis repetita dans une future discussion, l'ignorer sera mon choix certain et je ne serais pas le seul …

___________________________________________________________________________________________________________

L'effort fait les forts …

[unparia]

l'ignorer sera mon choix certain et je ne serais pas le seul

Tu ne seras en effet alors pas le seul.

[informer]

La solution ne répond que partiellement à ma problématique car seule la moitié des items sont tirés au hasard
L'autre moitié ne subit qu'une permutation.

Donc la question reste d'actualité et merci pour ce remarquable échange épistolaire. Très distrayant !

[Marc-L]

Dans ce cas là une présentation digne de ce nom - claire & exhaustive avec tenants & aboutissants - s'impose ‼

Car pour un mélange - et non un tri ! - il est justement inutile de tout tirer ! …

___________________________________________________________________________________________________________

Ce que l'on conçoit bien s'énonce clairement, et les mots pour le dire arrivent aisément … (Nicolas Boileau)

[informer]

Tout est dans le titre qu'il faut prendre le temps de lire !

La question reste ouverte!

[patricktoulon]

bonjour informer

effectivement les copier/coller sont rarement concluants

il te faut pour cela connaitre le nombre de possibilités
tu trouvera comment dans mon code avec "P"
tu peux utiliser un dico ou collection qui n'acceptée pas les doublons
et remplir cet object dans une boucle qui s'arrête quand le count correspond au nombre de possibilités

tres tres simple

je te laisse analyser ces quelques lignes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
Sub test()
    Dim dico, tabo, p As Long
    With ActiveSheet
        Set dico = CreateObject("scripting.dictionary")
        tablo = .Range("A1:A8")
        p = Val(UBound(tablo) * UBound(tablo)) - UBound(tablo)
        Do
            DoEvents:
re1:             x1 = Round(Rnd * UBound(tablo)): If x1 = 0 Then GoTo re1
re2:             x2 = Round(Rnd * UBound(tablo)): If x2 = 0 Or x2 = x1 Then GoTo re2
            If Not dico.exists(.Cells(x1, 1) & " " & .Cells(x2, 1)) Then i = i + 1: dico(.Cells(x1, 1) & " " & .Cells(x2, 1)) = i
        Loop While i < p
        .Cells(1, 2).Resize(dico.Count, 1) = Application.Transpose(dico.keys)
    End With
    MsgBox p & " combinaisons trouvées"
End Sub

[informer]

Merci Patrick pour ta solution et cet apport constructif à ce post.

[unparia]

Bonjour Patrick

il te faut pour cela connaitre le nombre de possibilités
tu trouvera comment ....

Il trouvera de manière plus simple avec :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

WorksheetFunction.Combin(arg1, arg2)

non ?

[informer]

J'ai ce post Arrangement, récursivité et affichage (Cliquez ici) sans réponse, tout aide serait très appréciable

[informer]

Par contre Patrick la dimension hasard n'est pas intégrée dans ta solution et je ne veux pas toutes les combinaisons mais une combinaisons à chaque appel de la fonction

Si reprends l'exemple:

Exemple
Toto
Titi
Yoyo

Affichage après 1er appel
Toto -> Titi
Titi -> Yoyo
Yoyo -> Toto

Affichage après 2ième appel
Toto -> Yoyo
Titi -> Toto
Yoyo -> Titi

Tous les autres appels afficheront soit 1 ou 2 car aucun binôme avec les mêmes items n'est possible

[patricktoulon]

re
@jacques je sais pas trop
pour obtenir le même nombre qu'avec le calcul scolaire avec combin
j'ai huit mots

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
Sub test2()
MsgBox WorksheetFunction.Combin(8, 3)
End Sub

le 3 je comprends pas très bien en fait

[unparia]

le 3 je comprends pas très bien en fait

C'est pourtant simple et prêt à déguster comme au restaurant :
Nombre de combinaisons distinctes de 3 éléments parmi huit éléments (donc 56 combinaisons)

[informer]

Merci pour ces infos mais on s'éloigne du sujet de mon post qui est le suivant:

Si j'ai cette liste (Ici 3 items mais nombre d'items est indéfini) :

• Toto
• Titi
• Yoyo

Affichage après 1er appel

• Toto -> Titi
• Titi -> Yoyo
• Yoyo -> Toto

Affichage après 2ième appel

• Toto -> Yoyo
• Titi -> Toto
• Yoyo -> Titi

Tous les autres appels afficheront soit 1 ou 2 car aucun binôme avec les mêmes items n'est possible

[patricktoulon]

re
heu...... @jacques
je ne combine pas 3 mais 2 éléments hein !!!!

[patricktoulon]

re
informer
le model que je t'ai donné te donne tout les possibilité par rapport a une liste dans une colonne
il ne te reste qu'a modifier la plage
je vois pas ce que tu veux d'autre

[informer]

Patrick,

L'idée de départ c'est d'attribuer au hasard une personne à une autre pour lui offrir un cadeau (Mini noël).

Soit la liste des participants

• Moi
• Toi
• Lui
• Elle
• Nous

Le premier appel affiche de façon aléatoire
(-> : offre cadeau à)

Col A Col B

• Moi -> Lui
• Toi -> Nous
• Lui->Toi
• Elle->Moi
• Nous->Elle

Si je relance alors cela donne de façon aléatoire

• Moi->Nous
• Toi->Lui
• Lui->Toi
• Elle->Moi
• Nous->Elle

Et ainsi de suite à chaque relance

J'ai joint le fichier. Et mon problème tient aux lignes

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
    If Cells(i, 1).Value = Tableau(1) Or Cells(i + 1, 1).Value = Tableau(2) Then
        Cells(i, 2).Value = Tableau(2)
        Cells(i + 1, 2).Value = Tableau(1)
    Else
        Cells(i, 2).Value = Tableau(1)
        Cells(i + 1, 2).Value = Tableau(2)
 
    End If

Qui sortent de la boucle Do While ce que je ne trouve pas joli