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]

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)

 

[mapomme]

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]

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

 

[caramote13]

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.

Marche aussi très bien avec cette méthode