Bonjour le forum,

Je cherche à éliminer les doublons lors du tirage d'un programme de pétanque.
Je vous joins la macro du tirage et tiens à votre disposition le programme en question.

J'utilise excel 2003 et windows 7

D'avance, merci, pour votre aide précieuse.

Amicalement

Margar

ps : je suis nul en excel

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