Titre du sujet : Eliminer doublons dans macro tirage par MARGAR le 04/05/2012 15:14:37
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
|