Eliminer doublons dans macro tirage
#1
Débutant XLPages

Inscription: 04/05/2012
De LIEGE BELGIQUE

Messages: 1

Système d'exploitation:
PC
Version Excel utilisée:
2003
Posté le : 04-05-2012 15h14

   bonjour le forum,
Le programme de pétanque que je possède fonctionne très bien sauf que j'ai plusieurs doublons lorsque je fais le tirage.
Càd qu'il y a plusieurs fois 2 joueurs qui jouent ensemble.

Je vous sollicite afin de trouver la solution pour qu'il n'y ait plus de doublons entre ceux-ci?

Merci de pouvoir m'aider.

Amicalement
Margar

PS : ci-joint la macro
code :
Sub Tirage()
Dim Tablo, temp
Dim I As Integer, J As Long, k As Integer, L As Byte
Dim NbJ As Integer
Dim Nb3 As Long
Dim Nb2 As Long
Dim Num As Long
Dim Cl As Integer
Dim NbManche As Byte
Dim Alea  As Integer
Dim Cel As Range
Dim Plage As Range

'Stop
  With Sheets("Liste")
    '.Unprotect
  Tablo = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
 End With
  NbJ = UBound(Tablo)

  'If NbJ < 4 Or NbJ = 7 Or NbJ > 54 Then
   ' MsgBox "Minimum 4 Maximum 54 et pas le nombre 7"
   ' Exit Sub
  'End If
 
  'Do
  '  NbManche = InputBox("Nombre de manches 3,4,5", "Tirage du nombre de manches")
  'Loop Until NbManche >= 3
 
  'Affichage du tableau dans l'onglet Recap
  With Sheets("Recap")
    .Unprotect
    .Range("B3:B100").ClearContents
    For I = 1 To NbJ
      .Cells(I + 2, 2) = Tablo(I, 1)
    Next I
    .Protect
  End With
 
  Select Case NbJ Mod 3                      ' Multiple de 3 ?
    Case 0
      If (NbJ / 3) Mod 2 > 0 Then            ' Nombre équipe impair
        Nb3 = (NbJ / 3) - 2
        Nb2 = 3
      Else
        Nb3 = NbJ / 3
        Nb2 = 0
      End If
    Case 1
      If ((NbJ \ 3) - 1) Mod 2 = 0 Then      ' 1 équipe de 3 en moins = nombre pair
        Nb3 = (NbJ \ 3) - 1
        Nb2 = 2
      Else
        Nb3 = (NbJ \ 3) - 3
        Nb2 = 5
      End If
    Case 2
      If (NbJ \ 3) Mod 2 = 0 Then             ' Nombre équipe de 3 pair
        Nb3 = (NbJ \ 3) - 2
        Nb2 = 4
      Else
        Nb3 = (NbJ \ 3)
        Nb2 = 1
      End If
  End Select
 
  ' On efface tous les tableaux
  For L = 1 To 5
    Sheets("P" & L).Range("A4:H12,I4:I12").ClearContents
    'Sheets("P" & L).Range("A4:F12,I4:I12").ClearContents
    'Sheets("P" & L).Range("A4:F12").ClearContents
    'Sheets("P" & L).Range("G4:H12") = 0
  Next L
 
  Randomize
 
  ReDim Preserve Tablo(1 To UBound(Tablo, 1), 1 To UBound(Tablo, 2) + 1)
If UserForm1.OptionButtonManche3 = True Then NbManche = 3
If UserForm1.OptionButtonManche4 = True Then NbManche = 4
If UserForm1.OptionButtonManche5 = True Then NbManche = 5
  For L = 1 To NbManche
    ' Numérotation aléatoire des joueurs
    For I = 1 To UBound(Tablo, 1)
      Tablo(I, UBound(Tablo, 2)) = Rnd
    Next I
    ' Tri en fonction du numérotage
    For I = 1 To UBound(Tablo, 1)
      For J = 1 To UBound(Tablo, 1)
        If Tablo(I, UBound(Tablo, 2)) > Tablo(J, UBound(Tablo, 2)) Then
          For k = 1 To UBound(Tablo, 2)
            temp = Tablo(I, k)
            Tablo(I, k) = Tablo(J, k)
            Tablo(J, k) = temp
          Next k
        End If
      Next J
    Next I
     
    With Sheets("P" & L)
'      .Range("A4:H12").ClearContents
      J = 4                                                           ' 1ère ligne
      Cl = 1
      Num = 0
      For I = 1 To Nb3                                                ' Pour toutes les triplettes
        For k = 0 To 2                                                ' Pour 3 joueurs
          Num = Num + 1                                               ' Indice dans le tableau : Tablo
          .Cells(J, Cl) = Tablo(Num, 1)
          Cl = Cl + 1
          If Cl = 7 Then
            Cl = 1
            J = J + 1
          End If
        Next k
      Next I

      For I = 1 To Nb2                                                ' Pour toutes les doublettes
        For k = 0 To 1                                                ' Pour 2 joueurs
          Num = Num + 1                                               ' Indice dans le tableau : Tablo
          .Cells(J, Cl) = Tablo(Num, 1)
          Cl = Cl + 1
          If Cl = 3 Then
            Cl = 4
          ElseIf Cl = 6 Then
            Cl = 1
            J = J + 1
          End If
        Next k
      Next I
     
            Set Plage = .Range("I4:I" & J - 1)
      For Each Cel In Plage
Autre:
        Alea = Int(9 * Rnd + 1)
        If Application.CountIf(Plage, Alea) Then GoTo Autre Else Cel = Alea
      Next Cel

      .Columns("A:H").AutoFit
    End With
  Next L
  Application.ScreenUpdating = True

End Sub

Hors Ligne
Rapport   Haut 


Vous pouvez voir les sujets.
Vous ne pouvez pas débuter de nouveaux sujets.
Vous ne pouvez pas répondre aux contributions.
Vous ne pouvez pas éditer vos contributions.
Vous ne pouvez pas effacez vos contributions.
Vous ne pouvez pas ajouter de nouveaux sondages.
Vous ne pouvez pas voter en sondage.
Vous ne pouvez pas attacher des fichiers à vos contributions.
Vous ne pouvez pas poster sans approbation.

[Recherche avancée]


Qui consulte actuellement ce sujet ?   1 Utilisateur(s) anonymes