Macro sans doublons face à face

[caramote13]

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 😉

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

 

[Dranreb]

Bonjour.
Différents dans chaque colonne, peuvent-ils néanmoins se retrouver ensembles dans plusieurs lignes ?

 

[caramote13]

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 ;-)

 

[Dranreb]

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 !

 

[youky(BJ)]

Salut à tous
Voici un exemple
décocher application.screnn...pour voir le déroulement de la macro
Bruno

 

[youky(BJ)]

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

 

[Dranreb]

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.

 

[klin89]

Bonjour à tous,🙂

Pour résumé, tu veux obtenir ceci :

klin89

 

[caramote13]

Oui klin89 ! c'est exactement cela mais avec uniquement trois colonnes 😉

 

[caramote13]

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

SUPER ! marche nickel 🙂
Un grand merci à tous et spécialement à toi youky(BJ)

 

[job75]

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

Voyez le fichier joint et cette macro :

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+

 

[Dranreb]

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.

 

[caramote13]

Merci à tous vraiment sympa les amis.
Ça marche nickel !

 

[mapomme]

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

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.

 

[mapomme]

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.