Gestion d'absence sur site de travail

bonsoir


un code - attention - A TESTERRRRRRRRRRRRRR


Stéphane




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 tampon As Variant


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"


Set plgABSENTS = [ABSENCES].Offset(1).Resize([ABSENCES].Rows.Count - 1, 1)
Set plgREMPACANTSDISPONIBLES = [REMPLACANTS].Offset(1).Resize([REMPLACANTS].Rows.Count - 1, 1)
nbABSENTS = plgABSENTS.SpecialCells(xlCellTypeConstants).Count

' Boucle sur la plage Absences et récupération de l'absent de chaque cellule non vide
For Each ABSENT In plgABSENTS

idxnbABSENTS = idxnbABSENTS + 1

If Not IsEmpty(ABSENT.Value) Then

nbREMPLACANTSDISPONIBLES = plgREMPACANTSDISPONIBLES.SpecialCells(xlCellTypeConstants).Count
ReDim lstREMPLACANTSDISPONIBLES(0 To nbREMPLACANTSDISPONIBLES - 1, 2)

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

strREMPLACANTCHOISI = lstREMPLACANTSDISPONIBLES(Int((UBound(lstREMPLACANTSDISPONIBLES) - LBound(lstREMPLACANTSDISPONIBLES) + 1) * Rnd + LBound(lstREMPLACANTSDISPONIBLES)), 0)

For Each PERSONNEABSENTE In [PlanningDetail].SpecialCells(xlCellTypeConstants)

If PERSONNEABSENTE.Value = ABSENT.Value Then


PERSONNEABSENTE.Value = Replace(PERSONNEABSENTE.Value, ABSENT.Value, strREMPLACANTCHOISI, , vbTextCompare)
PERSONNEABSENTE.Interior.ColorIndex = 35

'enlever cette personne de la liste des remplacants disponibles
ReDim tampon(0 To nbREMPLACANTSDISPONIBLES - 2, 2)


End If


Next PERSONNEABSENTE

End If
idx = 0
' strREMPLACANTCHOISI = ""
For i = LBound(lstREMPLACANTSDISPONIBLES) To UBound(lstREMPLACANTSDISPONIBLES) 'LBound(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

[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

If idxnbABSENTS < nbABSENTS Then
If MsgBox(ABSENT.Value & " a été remplacé par " & strREMPLACANTCHOISI & vbCr & "Voulez-vous poursuivre ?", vbYesNoCancel) <> vbYes Then
Exit Sub
End If
End If



Next ABSENT



End Sub

Bonjour...Et merci

J'ai inclu la macro dans la feuille....mais au lancement de celle-ci, excel m'annonce une erreur de type '1004'.... et m'indique que la ligne 'nbABSENTS = plgABSENTS.SpecialCells(xlCellTypeConstants).Count'' contient, à priori, une erreur....mais laquelle !?


Merci encore


Alexandre

bonjour

comme j'ai écrit la macro, elle ne marchera que s'il y a des absents.
et que les absents soient spécifiés en dur et non pas générées par une formule.

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

Bonjour....

j'ai intégré le code dans la feuille.... mais au lancement de la macro, autre message d'erreur... Erreur de compilation à priori. Et j'avoue avoir du mal à décrypter les nombreuses lignes du code vba là.

Merci tout de même


Alexandre

bjr

et regarde un peu le code, lors de ta copie, des sauts de ligne ont été insérées de partout

regarde ci-joint

oups, il y a un bogue (bug) à corriger -> lorsqu'il n'y a plus assez d'absents

steph