Macro sans doublons face à face

caramote13

XLDnaute Nouveau
Bonjour à vous tous
Je voudrais lors de mon tirage que les noms sur trois colonnes ne soit pas identiques face à face comme sur l'exemple en pièce jointe.
Ma Macro ci-dessous
Merci à vous tous par avance.
Pierre ;)
Code:
Sub Tirage_au_sort()
Dim i As Integer, DerLig As Integer

Application.ScreenUpdating = False

With Sheets("Pour les noms au hasard")
    DerLig = .Range("A1048576").End(xlUp).Row
     .Range("A2:A" & DerLig).Copy Destination:=.Range("F2")

    For i = 2 To DerLig
        .Range("E" & i) = Rnd
    Next
    .Range("E2:F" & DerLig).Sort Key1:=.Range("E2"), Order1:=xlAscending, Header:=xlNo

    Range("C4") = .Range("F2")
    Range("C5") = .Range("F3")
    Range("C6") = .Range("F4")
    Range("C7") = .Range("F5")
    Range("C8") = .Range("F6")
    Range("C9") = .Range("F7")
    Range("C10") = .Range("F8")
    Range("C11") = .Range("F9")
    Range("C12") = .Range("F10")
    Range("C13") = .Range("F11")
    Range("C14") = .Range("F12")
    Range("C15") = .Range("F13")
    Range("C16") = .Range("F14")
    Range("C17") = .Range("F15")
    Range("C18") = .Range("F16")
    Range("C19") = .Range("F17")

    .Range("E2:F1048576").ClearContents

    With Sheets("Pour les noms au hasard")
    DerLig = .Range("B1048576").End(xlUp).Row
    .Range("B2:B" & DerLig).Copy Destination:=.Range("F2")
    For i = 2 To DerLig
        .Range("E" & i) = Rnd
    Next
    .Range("E2:F" & DerLig).Sort Key1:=.Range("E2"), Order1:=xlAscending, Header:=xlNo

    Range("D4") = .Range("F2")
    Range("D5") = .Range("F3")
    Range("D6") = .Range("F4")
    Range("D7") = .Range("F5")
    Range("D8") = .Range("F6")
    Range("D9") = .Range("F7")
    Range("D10") = .Range("F8")
    Range("D11") = .Range("F9")
    Range("D12") = .Range("F10")
    Range("D13") = .Range("F11")
    Range("D14") = .Range("F12")
    Range("D15") = .Range("F13")
    Range("D16") = .Range("F14")
    Range("D17") = .Range("F15")
    Range("D18") = .Range("F16")
    Range("D19") = .Range("F17")

    .Range("E2:F1048576").ClearContents

    With Sheets("Pour les noms au hasard")
    DerLig = .Range("C1048576").End(xlUp).Row
    .Range("C2:C" & DerLig).Copy Destination:=.Range("F2")
    For i = 2 To DerLig
        .Range("E" & i) = Rnd
    Next
    .Range("E2:F" & DerLig).Sort Key1:=.Range("E2"), Order1:=xlAscending, Header:=xlNo

    Range("E4") = .Range("F2")
    Range("E5") = .Range("F3")
    Range("E6") = .Range("F4")
    Range("E7") = .Range("F5")
    Range("E8") = .Range("F6")
    Range("E9") = .Range("F7")
    Range("E10") = .Range("F8")
    Range("E11") = .Range("F9")
    Range("E12") = .Range("F10")
    Range("E13") = .Range("F11")
    Range("E14") = .Range("F12")
    Range("E15") = .Range("F13")
    Range("E16") = .Range("F14")
    Range("E17") = .Range("F15")
    Range("E18") = .Range("F16")
    Range("E19") = .Range("F17")

    .Range("E2:F1048576").ClearContents
End With
End With
End With

End Sub
 

Pièces jointes

  • Copie de Aléatoires JURY 1.xlsm
    63 KB · Affichages: 33
Dernière édition:

caramote13

XLDnaute Nouveau
Bonjour Dranreb
Non il ne doit pas y avoir plusieurs noms différents dans plusieurs lignes, mais une seule fois répéter dans chaque colonnes.
Il y a 16 noms dans une colonne, 16 identiques dans les deux autres, mais il ne doivent jamais se retrouver en face l'un de l'autre.
en clair dans la colonne A, 16 noms, colonnes B et C, 16 noms identiques et il faut qu'ils ne se croisent jamais face à face dans chaque lignes.

Note: Sur l'exemple j'ai oublié la première ligne ou il y a aussi un doublon JLS répéter deux fois ;-)
 
Dernière édition:

Dranreb

XLDnaute Barbatruc
Ce n'était pas ma question.
Si on a dans une ligne le 7ième et le 13ième, ces deux là peuvent ils aussi être ensembles, en colonnes interverties, forcément, bien sûr, dans une autre ligne ?
Ou bien chacun ne doit -il être qu'une seule fois face à un autre ?
Ce sera compliqué de toute façon. La question est plutôt de savoir si ce sera faisable.
J'envisage un algorithme dont la durée probable sera une factorielle d'une inconnue aléatoire en distribution normale. Ce qui veut dire en clair qu'il aura par exemple une durée la plus probable d'un dixième de seconde, une durée considérablement moins probable de quelque nanosecondes seulement, mais que cette même probabilité soit partagée par une éventualité que ça nécessite … plusieurs semaines si on le laissait tourner jusqu'au bout !
 
Dernière édition:

youky(BJ)

XLDnaute Barbatruc
Toute petite rectif je recopiais pas tout des données
Edit:Bonjour Dranreb
Pour ma part je comprend qu'il ne faut pas de doublon des noms par colonne ni par ligne
 

Pièces jointes

  • Aléatoires JURY 1.xlsm
    63.9 KB · Affichages: 29

Dranreb

XLDnaute Barbatruc
Les essais de youky(Bj) m'incitent à penser que la contrainte supplémentaire ne devrait pas poser de problème, vu qu'elle semble à première vue le plus souvent respectée par hasard.
 
Dernière édition:

klin89

XLDnaute Accro
Bonjour à tous,:)

Pour résumé, tu veux obtenir ceci :

image.PNG

klin89
 

job75

XLDnaute Barbatruc
Bonjour caramote13, Bernard, Bruno, [edit] klin89,

Voyez le fichier joint et cette macro :
Code:
Sub Tirage_au_sortablo()
Dim tablo, liste, n&, d1 As Object, d2 As Object, d3 As Object, i&, t
tablo = [C4:E19] 'plage à adapter
liste = [J4:J19] 'plage à adapter
n = UBound(liste)
If n < UBound(tablo) Then MsgBox "Liste des sociétés insuffisante !", 48: Exit Sub
On Error GoTo 1
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
Set d3 = CreateObject("Scripting.Dictionary")
Randomize
1 d1.RemoveAll: d2.RemoveAll: d3.RemoveAll 'RAZ
For i = 1 To UBound(tablo)
  tablo(i, 1) = liste(Int(1 + n * Rnd), 1)
  Do While d1.exists(tablo(i, 1))
    tablo(i, 1) = liste(Int(1 + n * Rnd), 1)
  Loop
  d1(tablo(i, 1)) = ""
  tablo(i, 2) = liste(Int(1 + n * Rnd), 1)
  t = Timer
  Do While d2.exists(tablo(i, 2)) Or tablo(i, 2) = tablo(i, 1)
    If Timer - t > 0.1 Then GoTo 1 'délai d'attente de 0.1 seconde
    tablo(i, 2) = liste(Int(1 + n * Rnd), 1)
  Loop
  d2(tablo(i, 2)) = ""
  tablo(i, 3) = liste(Int(1 + n * Rnd), 1)
  t = Timer
  Do While d3.exists(tablo(i, 3)) Or tablo(i, 3) = tablo(i, 1) Or tablo(i, 3) = tablo(i, 2)
    If Timer - t > 0.1 Then GoTo 1 'délai d'attente de 0.1 seconde
    tablo(i, 3) = liste(Int(1 + n * Rnd), 1)
  Loop
  d3(tablo(i, 3)) = ""
Next
[C4:E19] = tablo
End Sub
Avec des tableaux VBA c'est très rapide.

Mais certains tirages ne peuvent aboutir et les 2ème et 3ème boucles Do/Loop doivent être alors arrêtées.

J'ai mis un délai de 0.1 seconde au bout duquel tout le processus est recommencé.

Notez les vérifications des résultats en colonne B et en ligne 21.

A+
 

Pièces jointes

  • Aléatoires JURY(1).xlsm
    62.8 KB · Affichages: 23
Dernière édition:

Dranreb

XLDnaute Barbatruc
La version qui respecte la seconde contrainte :
Deux noms ne peuvent figurer ensembles que sur une seule ligne.
Remarque: J'ai passé un temps fou à faire une partie seulement du ménage dans les mises en forme conditionnelles.
 

Pièces jointes

  • ListeAléatCaramote13.xlsm
    76.1 KB · Affichages: 24

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir à tous,

Une autre macro. Le code est dans le module de la feuille Feuil1.On ne touche pas à la première colonne du tableau puisque tous les sociétés doivent y figurer (autant qu’elles soient triées)

Tout ce qui entoure le tableau peut-être supprimé. Ce ne sont que des vérifications. Le code est dans le module de code de la feuille contenant le tableau (ici il s'agit de la feuille Feuil1).
VB:
Sub tirage2()
Dim k1&, k2&

  On Error GoTo ERR001
  Application.ScreenUpdating = False
  Application.Calculation = xlCalculationManual

  Randomize: k1 = 5 + Int(Rnd * 15)
  Range("c4").Resize(19 - k1 + 1).Copy Cells(k1, "d")
  Range(Range("c4").Offset(19 - k1 + 1), Cells(19, "c")).Copy Cells(4, "d")

  Do: k2 = 5 + Int(Rnd * 15): Loop Until k2 <> k1
  Range("c4").Resize(19 - k2 + 1).Copy Cells(k2, "e")
  Range(Range("c4").Offset(19 - k2 + 1), Cells(19, "c")).Copy Cells(4, "e")
ERR001:
  On Error Resume Next
  Application.Calculation = xlCalculationAutomatic
End Sub

nota : merci à klin89 ;) qui m'a donné l'idée de la méthode.
 

Pièces jointes

  • caramote13- tirage sans doublons- v1a.xlsm
    29.3 KB · Affichages: 35

mapomme

XLDnaute Barbatruc
Supporter XLD
reBonsoir à tous,

Une nouvelle version qui ajoute une condition supplémentaire : toute société doit être obligatoirement associée à des jury tous différents. Autrement dit, une société, apparaissant dans trois lignes, a donc toujours 6 sociétés différentes au sein des trois lignes où elle apparait.

Pour cela une fonction nbrItemAss() a été créée dans module1.
 

Pièces jointes

  • caramote13- tirage sans doublons- v2.xlsm
    21.7 KB · Affichages: 22

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 941
Membres
101 847
dernier inscrit
Djigbenou