faire un tirage sans remise
Bonjour,
Je fais un planning de gestion des agents.
Mon programme prend de la feuille "compétences", les agents dont la cellule n'est pas rouge et dont la cellule comprend des 1.
Il les met ensuite dans un planning de la feuille "mois en cours", mais pas dans les cellules jaunes.
Tout marche bien jusque là mais les noms des agents se répètent d'une colonne à l'autre.
Je voudrais qu'un nom ne se mette que dans une cellule d'une ligne car en ligne se trouve les jours et en colonne leurs activités.
Un agent ne peut faire qu'une activité par jour.Il faudrait donc je suppose modifier mon code en tirage sans remise.
Merci de m'aider.
Voilà mon code:
Bonjour,
Je fais un planning de gestion des agents.
Mon programme prend de la feuille "compétences", les agents dont la cellule n'est pas rouge et dont la cellule comprend des 1.
Il les met ensuite dans un planning de la feuille "mois en cours", mais pas dans les cellules jaunes.
Tout marche bien jusque là mais les noms des agents se répètent d'une colonne à l'autre.
Je voudrais qu'un nom ne se mette que dans une cellule d'une ligne car en ligne se trouve les jours et en colonne leurs activités.
Un agent ne peut faire qu'une activité par jour.Il faudrait donc je suppose modifier mon code en tirage sans remise.
Merci de m'aider.
Voilà mon code:
Code:
Sub Nom_FIP_2(w() As String)
Dim v As Byte, c As New Collection, x As Integer, y() As Variant, z() As Variant, i As Byte
Randomize
y = Array(16, 17, 18)
z = Array(9, 25, 42)
For i = 0 To 2
Do While c.Count < 4
cpt% = cpt% + 1
If cpt% > MAX_ITER Then
cpt% = 0
Exit Do
End If
x = Int(y(i) * Rnd + z(i))
If Cells(x, 3) = 1 And Cells(x, 3).Interior.ColorIndex <> 3 Then
On Error Resume Next
c.Add Cells(x, 3).Address, CStr(Cells(x, 3).Address)
If Err = 0 Then
On Error GoTo 0
w(v) = Cells(x, 2).Value
v = v + 1
End If
On Error GoTo 0
End If
Loop
Set c = Nothing
Next i
End Sub
Sub FIP_AIP_MUSC_2()
Dim p As Range, v As Byte, w(12) As String
Nom_FIP_2 w
For Each p In Sheets("Mois en cours").Range("F4:F18")
If p.Interior.ColorIndex <> 6 And IsEmpty(p.Value) Then
p.Value = w(0)
For v = 1 To UBound(w)
p.Value = p.Value & "/" & w(v)
Next v
End If
Next p
Nom_FIP_2 w
For Each p In Sheets("Mois en cours").Range("F19:F34")
If p.Interior.ColorIndex <> 6 And IsEmpty(p.Value) Then
p.Value = w(0)
For v = 1 To UBound(w)
p.Value = p.Value & "/" & w(v)
Next v
End If
Next p
End Sub
Dernière édition: