Corriger ma macro de 3 à 2

[MARGAR]

Bonsoir le forum,

J'ai une macro dont le tirage se compose de triplettes et de doublettes.
N"étant pas un expert en vba et après différents essais, je ne parviens pas à résoudre mon problème.
C'est-à-dire d'obtenir un tirage uniquement de doublettes.
Serait-il possible d'avoir un avis, une idée, une aide afin de résoudre celui-ci.
Cordialement
margar

ci-joint le code

Option Explicit

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
'Stop
With Sheets("Liste")
'.Unprotect
Tablo = .Range("A2:A" & .Range("A" & Rows.Count).End(xlUp).Row)
End With
NbJ = UBound(Tablo)



'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: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
.Range("C14") = Format(Date, "DD-MM-YYYY")
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
.Columns("A:H").AutoFit
End With
Next L
Application.ScreenUpdating = True

End Sub

 

[bbb38]

Re : Corriger ma macro de 3 à 2

Bonjour MARGAR, le forum,
Pour ma part difficile de rectifier ton code. Si tu peux joindre un fichier exemple, je pense que tu auras plus de chance d’avoir des réponses (cela évitera d’essayer de reconstituer les feuilles et le formulaire.
Cordialement,
Bernard

 

[MARGAR]

Re : Corriger ma macro de 3 à 2

Bonsoir bbb38, le forum,
Merci de me répondre, voici le fichier en question : code vba : MARCEL
Cordialement
margar