Private Sub Worksheet_Change(ByVal Target As Range)
'
Dim plan As Worksheet, auxil As Worksheet, coll As New Collection
Dim xrgValid As Range, n&, x, I&, k&
Dim cellsBtoN As Range, cell As Range, cellQ As Range
Dim Nbcb As Long, Nbcv As Long
Dim aaa
Application.ScreenUpdating = False
Set plan = Worksheets("PLANNING")
' Création d'une feuille nommée "Auxilxxx" (si elle existe déjà on commence par la supprimer)
On Error Resume Next
Application.DisplayAlerts = False
Application.Worksheets("Auxilxxx").Delete
Application.DisplayAlerts = True
On Error GoTo 0
With Application.Worksheets.Add: .Name = "Auxilxxx": End With
Set auxil = Worksheets("Auxilxxx")
' On met le texte, des colonnes B à N, en noir et non gras
plan.Range("B3:N" & Rows.count).Font.Color = vbBlack
plan.Range("B3:N" & Rows.count).Font.Bold = False
' Affectation à la variable xrgValid de toutes les cellules du tableau contenant une liste déroulante
Set xrgValid = plan.[B5].SpecialCells(xlCellTypeSameValidation)
'---------- Calcule le nombre de cellules non vides de la plage ------
Nbcv = xrgValid.count ' Nombre de cellules de la plage (la plage étant l'ensemble des cellules du tableau ayant une liste déroulante)
Nbcb = xrgValid.SpecialCells(xlCellTypeBlanks).count ' Nombre de cellules vides de la plage (la plage étant l'ensemble des cellules du tableau ayant une liste déroulante)
'-----------------------------------------------------------------
ReDim t(1 To Nbcv - Nbcb, 1 To 6)
auxil.Cells.Delete
For Each x In xrgValid.Cells
If x.Value <> "" Then
If x.Offset(-1) <> "" Then
n = n + 1
t(n, 1) = x.Column
t(n, 2) = x.Value
t(n, 3) = TimeValue(Split(x.Offset(-1), "-")(0))
t(n, 4) = TimeValue(Split(x.Offset(-1), "-")(1))
t(n, 5) = x.Row
t(n, 6) = Format(t(n, 1), "0000") & String(50 - Len(t(n, 2)), " ") & t(n, 2) & Format(t(n, 3), "hhmm") & Format(t(n, 4), "hhmm")
End If
End If
Next x
auxil.[A1].Resize(n, 6) = t
auxil.[A1].Resize(n, 6).Sort key1:=auxil.[F1], order1:=xlAscending, MatchCase:=False, Header:=xlNo
t = auxil.[A1].Resize(n, 5).Value
' On supprime la feuille nommée "Auxilxxx"
On Error Resume Next
Application.DisplayAlerts = False
auxil.Delete
Application.DisplayAlerts = True
On Error GoTo 0
For I = 2 To UBound(t)
If t(I, 1) = t(I - 1, 1) And t(I, 2) = t(I - 1, 2) And t(I, 3) < t(I - 1, 4) Then
plan.Cells(t(I, 5), t(I, 1)).Font.Color = vbRed
plan.Cells(t(I, 5), t(I, 1)).Font.Bold = True
plan.Cells(t(I - 1, 5), t(I - 1, 1)).Font.Color = vbRed
plan.Cells(t(I - 1, 5), t(I - 1, 1)).Font.Bold = True
On Error Resume Next
coll.Add "", t(I, 5) & "/" & t(I, 1)
coll.Add "", t(I - 1, 5) & "/" & t(I - 1, 1)
On Error GoTo 0
End If
Next I
' Nouveau code pour la mise en forme conditionnelle basée sur la liste déroulante
' Set cellsBtoN = plan.Range("B:N")
Set cellsBtoN = xrgValid
If Not Intersect(Target, cellsBtoN) Is Nothing Then
For Each cell In Intersect(Target, cellsBtoN)
If cell.Value <> "" Then
Set cellQ = plan.Columns("S:S").Find(What:=cell.Value, LookIn:=xlValues, LookAt:=xlWhole)
If Not cellQ Is Nothing Then cell.Interior.Color = cellQ.Interior.Color
End If
Next cell
End If
End Sub