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&
Application.ScreenUpdating = False
Set plan = Worksheets("Planning")
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")
If Intersect(Target, plan.Columns("b:n")) Is Nothing Then Exit Sub
plan.Range("b3:n" & Rows.count).Font.Color = vbBlack
plan.Range("b3:n" & Rows.count).Font.Bold = False
Set xrgValid = plan.[b5].SpecialCells(xlCellTypeSameValidation)
ReDim t(1 To 3 * plan.UsedRange.Rows.count / 3, 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 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
If coll.count > 0 Then MsgBox coll.count & " plages en chevauchement.", vbExclamation
End Sub