Private Sub Worksheet_Change(ByVal Target As Range)
'-----
Worksheet_Activate 'pour mise à jour des couleurs
End Sub
Private Sub Worksheet_Activate()
Dim cc%, dat, conges, ub&, t, d As Object, i&, x$, y$, test1, test2
Dim lig&, col%, CP As Range, AM As Range, CE As Range, CH As Range
Dim c As Range, a
Application.ScreenUpdating = False
With [B6:GE58] '58 à adapter au nombre de noms
cc = .Columns.Count
dat = .Rows(0).Value
conges = Feuil2.[A1].CurrentRegion.Resize(, 5) 'CodeName de la feuille
ub = UBound(conges)
.Interior.ColorIndex = xlNone 'RAZ des couleurs
'---liste des noms (sans doublon)pour accélérer---
t = .Columns(0).Resize(, 2) 'au moins 2 éléments
Set d = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(t)
If t(i, 1) <> "" Then d(t(i, 1)) = i 'repérage de la ligne
Next
If d.Count = 0 Then Exit Sub 'si aucun nom
'---création des zones de couleur à partir du tableau des congés---
For i = 2 To UBound(conges)
If d.exists(conges(i, 1)) Then
x = conges(i, 4): y = conges(i, 5)
test1 = y = "AM" Or y = "": test2 = y = "PM" Or y = ""
lig = d(conges(i, 1)) 'utilise le repérage
For col = 1 To cc Step 2
If dat(1, col) >= conges(i, 2) And dat(1, col) <= conges(i, 3) Then
Set c = .Cells(lig, col)
Select Case x
Case "CP": Zone x, CP, c, test1, test2
Case "AM": Zone x, AM, c, test1, test2
Case "CE": Zone x, CE, c, test1, test2
Case "CH": Zone x, CH, c, test1, test2
End Select
End If
If dat(1, col) > conges(i, 3) Then Exit For
Next col
End If
Next i
'---restitution de ce qu'il reste à restituer---
a = Array("CP", "AM", "CE", "CH")
For i = 0 To UBound(a)
x = a(i)
Select Case x
Case "CP": Restitution x, CP
Case "AM": Restitution x, AM
Case "CE": Restitution x, CE
Case "CH": Restitution x, CH
End Select
Next
End With
End Sub
Sub Zone(x$, r As Range, c As Range, test1, test2)
If test1 Then Set r = Union(IIf(r Is Nothing, c, r), c)
If test2 Then Set r = Union(IIf(r Is Nothing, c(1, 2), r), c(1, 2))
'---restitution partielle pour alléger si trop de zones disjointes---
If r.Areas.Count > 100 Then Restitution x, r
End Sub
Sub Restitution(x$, r As Range)
Dim c As Range
Set c = [Couleurs].Cells(Application.Match(x, [Couleurs].Columns(2), 0), 1)
If Not r Is Nothing Then r.Interior.Color = c.Interior.Color: Set r = Nothing
End Sub