XL 2016 éviter le chevauchement de créneaux horaires

[halecs93]

Bonjour à toutes et à tous,

Grâce au forum, et la solution finale adoptée (merci sousou), j'ai avancé sur mon planning.

Il se trouve qu'à l'utilisation je me suis rendu compte qu'il pouvait y avoir des incohérences. Ex, AA travaille de 8:00 à 10:00 à un endroit et en même temps de 9:00 à 11:00 à un autre. Bref...il ne peut être à deux endroits au même moment

Y a t-il moyen d'envoyer une alerte au moment de la génération du planning ?

Encore un grand merci.

 

[mapomme]

Bonjour @halecs93 ,

Un essai dans le classeur joint.

• Le code est dans le module de la feuille "Planning".
• Il se déclenche quand on change une valeur du planning.
• La police de la cellule à liste déroulante d'une plage en chevauchement est mise en gras et en rouge.

Le code :

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

 

[halecs93]

Bonjour @halecs93 ,

Un essai dans le classeur joint.

• Le code est dans le module de la feuille "Planning".
• Il se déclenche quand on change une valeur du planning.
• La police de la cellule à liste déroulante d'une plage en chevauchement est mise en gras et en rouge.

Le code :

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

Bonjour (matinal). Et un grand merci.