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:

mapomme

XLDnaute Barbatruc
Supporter XLD
Bonsoir Dranreb :),
Oui c'est la condition également respectée par ma solution du #12.
Mais chez moi c'est à l'aide du DéjàRenc() As Boolean à une dimension, calculée par XTria(J, A)

Mille excuses, je n'avais pas lu le fil avec attention. Je vais examiner ta solution.
En lisant tes messages, j'ai compris pourquoi mon fichier était si long à s'ouvrir (Les MFC à foison). Du coup, je l'ai nettoyé aussi et publié à nouveau.
 

ROGER2327

XLDnaute Barbatruc
Bonjour à tous.

Un essai «déterministe» : pas de DO ... LOOP jusqu'à ce que ça veuille bien...

ℝOGER2327
#8511


Jeudi 12 Pédale 144 (Saint Hari Seldon, psychohistorien galactique - fête Suprême Quarte)
16 Ventôse An CCXXV, 1,9217h - épinard
2017-W10-1T04:36:43Z
 

Pièces jointes

  • Distribution.xlsm
    21 KB · Affichages: 27

caramote13

XLDnaute Nouveau
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.
Marche aussi très bien avec cette méthode :)
 

Discussions similaires

Statistiques des forums

Discussions
311 721
Messages
2 081 928
Membres
101 842
dernier inscrit
seb0390