Macro sans doublons face à face

  • Initiateur de la discussion Initiateur de la discussion caramote13
  • Date de début Date de début

Boostez vos compétences Excel avec notre communauté !

Rejoignez Excel Downloads, le rendez-vous des passionnés où l'entraide fait la force. Apprenez, échangez, progressez – et tout ça gratuitement ! 👉 Inscrivez-vous maintenant !

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

Dernière édition:
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.
 
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

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 🙂
 
- Navigue sans publicité
- Accède à Cléa, notre assistante IA experte Excel... et pas que...
- Profite de fonctionnalités exclusives
Ton soutien permet à Excel Downloads de rester 100% gratuit et de continuer à rassembler les passionnés d'Excel.
Je deviens Supporter XLD

Discussions similaires

  • Résolu(e)
XL pour MAC Target
Réponses
9
Affichages
2 K
Réponses
4
Affichages
1 K
Réponses
4
Affichages
2 K
Réponses
17
Affichages
2 K
Retour