Macro sans doublons face à face

caramote13 · 5 Mars 2017

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

Dranreb · 5 Mars 2017

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 · 5 Mars 2017

Bonsoir Dranreb ,

Dranreb à dit:
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 · 6 Mars 2017

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 · 6 Mars 2017

mapomme à dit:
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

Macro sans doublons face à face

caramote13

XLDnaute Nouveau

Pièces jointes

Dranreb

XLDnaute Barbatruc

mapomme

XLDnaute Barbatruc

ROGER2327

XLDnaute Barbatruc

Pièces jointes

caramote13

XLDnaute Nouveau

Discussions similaires