Nouvelle Version
Sub test()
Dim ABSENT As Range
Dim REMPLACANT As Range
Dim plgABSENTS As Range
Dim nbABSENTS As Integer
Dim idxnbABSENTS As Integer
Dim idx As Integer
Dim plgREMPACANTSDISPONIBLES As Range
Dim nbREMPLACANTSDISPONIBLES As Integer
Dim lstREMPLACANTSDISPONIBLES As Variant
Dim strREMPLACANTCHOISI As String
Dim REMPLACE As Boolean
Dim tampon As Variant
Application.ScreenUpdating = False
'Pour éventuellement supprimer les plages nommées
'Si ça plante ici, c'est que les plages n'existent pas
'ActiveWorkbook.Names("ABSENCES").Delete
'ActiveWorkbook.Names("PLANNINGDETAIL").Delete
'ActiveWorkbook.Names("REMPLACANTS").Delete
'Création des plages nommées
Range("I1:I55").Select
Range("I55").Activate
ActiveWorkbook.Names.Add Name:="REMPLACANTS", RefersToR1C1:= _
"=Feuil1!R1C9:R55C9"
ActiveWorkbook.Names.Add Name:="ABSENCES", RefersToR1C1:= _
"=Feuil1!R1C11:R55C11"
ActiveWorkbook.Names.Add Name:="PLANNINGDETAIL", RefersToR1C1:= _
"=Feuil1!R2C3:R55C7"
ActiveWorkbook.Names.Add Name:="PLANNINGDETAIL", RefersToR1C1:= _
"=Feuil1!R2C3:R55C7"
'Stockage des plages ABSETNS & REMPLACANTSDISPONIBLES dans des variables range
Set plgABSENTS = [ABSENCES].Offset(1).Resize([ABSENCES].Rows.Count - 1, 1)
Set plgREMPACANTSDISPONIBLES = [REMPLACANTS].Offset(1).Resize([REMPLACANTS].Rows.Count - 1, 1)
'Compte du nombre des absents spécifiés
nbABSENTS = plgABSENTS.SpecialCells(xlCellTypeConstants).Count
'Suppression des couleurs de la plage PLANNINGDETAIL
[PLANNINGDETAIL].Interior.ColorIndex = xlNone
' Boucle sur la plage Absences qui peut contenir des cellules vides
For Each ABSENT In plgABSENTS
'Compte du nombre d'absents traités
idxnbABSENTS = idxnbABSENTS + 1
'Réinitialisation de la variable idx pour le compte du nombre de remplacants disponibles,
'redéterminé à chaque itération de la boucle
idx = 0
'Si la cellule lue dans l'itération n'est pas vide,
'alors on effectue le traitement de recherche de la personne correspondante dans le tableau planning
'et éventuellement le traitement de remplacement
If Not IsEmpty(ABSENT.Value) Then
'Compte du nombre de remplacants disponibles,
'redéterminé à chaque itération de la boucle
nbREMPLACANTSDISPONIBLES = plgREMPACANTSDISPONIBLES.SpecialCells(xlCellTypeConstants).Count
'Redimensionnement de mla variable tableau lstREMPLACANTSDISPONIBLES
ReDim lstREMPLACANTSDISPONIBLES(0 To nbREMPLACANTSDISPONIBLES - 1, 1)
'Boucle sur la plage plgREMPACANTSDISPONIBLES qui peut contenir des cellules vides
'pour stocker la liste des remplaçants disponibles dans la variable tableau lstREMPLACANTSDISPONIBLES
For Each rg In [plgREMPACANTSDISPONIBLES]
If Not IsEmpty(rg.Value) Then
lstREMPLACANTSDISPONIBLES(idx, 0) = rg.Value
lstREMPLACANTSDISPONIBLES(idx, 1) = rg.Address
idx = idx + 1
End If
Next rg
'Choix aléatoire d'un remplaçant
strREMPLACANTCHOISI = lstREMPLACANTSDISPONIBLES(Int((UBound(lstREMPLACANTSDISPONIBLES) - LBound(lstREMPLACANTSDISPONIBLES) + 1) * Rnd + LBound(lstREMPLACANTSDISPONIBLES)), 0)
'Boucle sur la plage PLANNINGDETAIL à la recherche de la personne absente
For Each PLANNINGTASK In [PLANNINGDETAIL].SpecialCells(xlCellTypeConstants)
If PLANNINGTASK.Value = ABSENT.Value Then
'Cette variable booléenne indique si oui ou non il y a eu un remplacement pour l'absent en cours
'autrement dit s'il était prévu qu'il travaille
REMPLACE = True
'Remplacement de l'absent par son remplaçant
PLANNINGTASK.Value = Replace(PLANNINGTASK.Value, ABSENT.Value, strREMPLACANTCHOISI, , vbTextCompare)
'Coloriage de la cellule où a eu lieu un remplacement remplacée
PLANNINGTASK.Interior.ColorIndex = 35
'Instruction pour permettre la suppresion de remplaçant de la liste des remplacantsnlever cette personne de la liste des remplacants disponibles
ReDim tampon(0 To nbREMPLACANTSDISPONIBLES, 1)
End If
Next PLANNINGTASK
End If
idx = 0
'Si au moins un remplacement a eu lieu, la variable tampon a été "initialisée"
'et les instructions ci-dessous l'alimenteront de la liste des remplaçants restants
If IsArray(tampon) Then
For i = LBound(lstREMPLACANTSDISPONIBLES) To UBound(lstREMPLACANTSDISPONIBLES)
If lstREMPLACANTSDISPONIBLES(i, 0) <> strREMPLACANTCHOISI Then
For j = 0 To 1
tampon(idx, j) = lstREMPLACANTSDISPONIBLES(i, j)
Next j
idx = idx + 1
End If
Next i
'effacement de la liste actuelle des remplaçants
'pour y coller ensuite celle des remplaçants restants
[I2].Resize(UBound(lstREMPLACANTSDISPONIBLES) + 1).ClearContents
With [I2].Resize(UBound(lstREMPLACANTSDISPONIBLES))
For i = 0 To .Cells.Count - 1
[I2].Offset(i).Value = tampon(i, 0)
Next i
End With
End If
If REMPLACE = True Then tx1 = ABSENT.Value & " a été remplacé par " & strREMPLACANTCHOISI & vbCr
If REMPLACE = False Then tx1 = ABSENT.Value & " n'a pas été remplacé."
If nbABSENTS > 1 And idxnbABSENTS < nbABSENTS Then tx1 = tx1 & "Voulez-vous poursuivre ?"
If idxnbABSENTS < nbABSENTS Then If MsgBox(tx1, vbOKCancel) <> vbOK Then Exit Sub
If idxnbABSENTS = nbABSENTS And REMPLACE = True Then MsgBox ("C'était le dernier absent - " & ABSENT.Value & " - il a été remplacé par " & strREMPLACANTCHOISI)
If idxnbABSENTS = nbABSENTS And REMPLACE = False Then MsgBox ("C'était le dernier absent - " & ABSENT.Value & " - il n'a pas été remplacé")
Next ABSENT
[A1].Activate
End Sub
