Sub Surligneur()
Dim r As Integer
Dim c As Integer
Dim x As Integer
Dim Ecart As Integer
Dim ShE As Worksheet
Dim ShC As Worksheet
Rem Définit les feuilles de travail
Set ShE = ThisWorkbook.Sheets("ECHEANCIER")
Set ShC = ThisWorkbook.Sheets("ACTIONS CLOSES")
Rem Supprime le surlignage précédent dans l'échéancier
ShE.Cells.Interior.ColorIndex = xlNone
Rem Désactive la mise à jour de l'écran pour améliorer la rapidité et le confort visuel
Application.ScreenUpdating = False
Rem Traitements
' Suppose que la ligne de titres du tableau est à la ligne 3
' traite de la fin du tableau jusqu'à sa première ligne de données
For r = ShE.UsedRange.Rows.Count To 4 Step -1
' ignore les lignes vides
If Application.WorksheetFunction.CountA(ShE.Range(Cells(r, 1), Cells(r, 9))) = 0 Then
GoTo ignore
End If
If IsDate(Cells(r, 8)) Then
' une date de réalisation a été saisie donc la ligne passe dans la feuille "Actions closes"
x = ShC.UsedRange.Rows.Count + 1
ShE.Rows(r).Cut
ShC.Activate
ShC.Cells(x, 1).Select
ActiveSheet.Paste
Application.CutCopyMode = False
ShC.Rows(x).Interior.ColorIndex = xlNone
ShE.Activate
ShE.Rows(r).Delete
ElseIf IsDate(ShE.Cells(r, 5)) Then
' surlignage pour les actions sans date de réalisation
Ecart = ShE.Cells(r, 5) - Date
Select Case Ecart
Case Is > 4
ShE.Range(Cells(r, 1), Cells(r, 9)).Interior.ColorIndex = xlNone
Case Is > 1
ShE.Range(Cells(r, 1), Cells(r, 9)).Interior.Color = RGB(255, 200, 0)
Case Is <= 1
ShE.Range(Cells(r, 1), Cells(r, 9)).Interior.Color = RGB(255, 0, 0)
End Select
Else
' surligne en bleu clair les actions sans échéance
ShE.Range(Cells(r, 1), Cells(r, 9)).Interior.Color = RGB(160, 255, 255)
End If
ignore:
Next