XL 2013 Colorer les jours dans un planning de présence (Résolu par JOB75)

Sub NewMonth_Sheet()
Dim w As Worksheet, dat As Date
For Each w In Worksheets
  If IsDate(w.Name) Then If CDate(w.Name) > dat Then dat = CDate(w.Name)
Next
If dat Then
  Application.ScreenUpdating = False
  Application.Goto ActiveSheet.[A1], True 'cadrage
  Sheets(Format(dat, "mmmm-yyyy")).Copy After:=Sheets(Sheets.Count)
  With Sheets(Sheets.Count)
    .Name = Application.Proper(Format(DateAdd("m", 1, dat), "mmmm-yyyy"))
    Application.EnableEvents = False
    With .Range("B10:AF" & .Rows.Count)
      .Value = Empty
      .Interior.ColorIndex = xlNone
      .Font.ColorIndex = 2 'police blanche
    End With
    Application.EnableEvents = True
    .Columns("AD:AF").Hidden = True '29 30 31
    .[AC8:AF8].SpecialCells(xlCellTypeFormulas, 1).Columns.Hidden = False
    .Visible = xlSheetVisible 'si la feuille est masquée
    Application.Goto .[A1], True 'cadrage
  End With
End If
End Sub

Sheets("Recap").Activate
Range("D" & Cells(Rows.Count, 4).End(xlUp).Row - 1).EntireRow.Copy
Range("A" & Cells(Rows.Count, 4).End(xlUp).Row).EntireRow.Insert Shift:=xlDown
Application.CutCopyMode = False

Private Sub Worksheet_Activate()
Dim deb As Range, critere As Range, a(), w As Worksheet, n%, i As Variant
Set deb = [D9] 'adapter éventuellement
Set critere = [E7] 'adapter éventuellement
ReDim a(1 To Worksheets.Count, 1 To 3)
For Each w In Worksheets
  If IsDate(w.Name) Then
    n = n + 1
    a(n, 1) = CDate(w.Name)
    a(n, 2) = w.Name
    a(n, 3) = Application.Sum(w.[AH8].CurrentRegion)
  End If
Next
Application.ScreenUpdating = False
critere.Validation.Delete 'RAZ
Rows(deb.Row + 1 & ":" & Rows.Count).Delete 'RAZ
If n = 0 Then Exit Sub
With deb(2, 0).Resize(n, 3) 'colonne auxiliaire C pour les dates
  .Value = a
  .Sort .Columns(1), Header:=xlNo 'tri
  .Columns(1) = Empty
  critere.Validation.Add xlValidateList, Formula1:="=" & .Columns(2).Address 'liste de validation
  i = Application.Match(critere, .Columns(2), 0)
  If IsError(i) Then
    .Rows(1).Resize(n).Hidden = True
  Else
    .Cells(i, 4).Resize(n - i + 1) = "=N(R[-1]C)+RC[-1]"
    .Cells(n + 1, 2) = "TOTAL"
    .Cells(n + 1, 3) = "=SUM(R[" & i - n - 1 & "]C:R[-1]C)"
    .Cells(n + 1, 4) = "=R[-1]C"
    .RowHeight = 22
    .Rows(n + 1).RowHeight = 27
    If i > 1 Then .Rows(1).Resize(i - 1).Hidden = True
  End If
End With
With Me.UsedRange: End With 'actualise la barre de défilement verticale
ActiveWindow.ScrollRow = 1
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [E7]) Is Nothing Then Worksheet_Activate
End Sub

Rows(deb.Row + 1 & ":" & Rows.Count).Delete 'RAZ, à tester

'deb.CurrentRegion.Offset(1).EntireRow.Delete 'ne change pas grand-chose

Rows.Hidden = False 'RAZ nouveau
Rows(deb.Row + 1 & ":" & Rows.Count).RowHeight = 22 'RAZ nouveau
Rows(deb.Row + 1 & ":" & Rows.Count) = Empty 'RAZ nouveau

Private Sub Worksheet_Activate()
Dim deb As Range, critere As Range, a(), w As Worksheet, n%, i As Variant
Set deb = [D12] 'adapter éventuellement
Set critere = [E9] 'adapter éventuellement
'---MAJ de la liste des mois---
ReDim a(1 To Worksheets.Count, 1 To 2)
For Each w In Worksheets
  If IsDate(w.Name) Then
    n = n + 1
    a(n, 1) = CDate(w.Name)
    a(n, 2) = w.Name
  End If
Next
Application.ScreenUpdating = False
critere.Validation.Delete 'RAZ
With Sheets("DATA")
  .Range("A2:B" & .Rows.Count) = Empty
  .[A2].Resize(n, 2) = a
  .[A2].Resize(n, 2).Sort .[A2], Header:=xlNo 'tri sur les dates
  .[B2].Resize(IIf(n, n, 1)).Name = "Sheetlist" 'plage nommée
  i = Application.Match(critere, [Sheetlist], 0)
End With
If n Then critere.Validation.Add xlValidateList, Formula1:="=Sheetlist"
'---remplissage de la feuille RECAP---
Rows(deb.Row & ":" & Rows.Count).RowHeight = 22 'hauteur modifiable
Rows(deb.Row & ":" & Rows.Count) = Empty 'RAZ
If n = 0 Or IsError(i) Then Exit Sub
With Sheets(CStr(critere)).[A9].CurrentRegion.Offset(2)
  n = .Rows.Count - 2
  If n < 1 Then Exit Sub
  deb.Resize(n) = .Columns(1).Value
  deb(1, 2).Resize(n, [Codes].Count) = .Cells(1, 34).Resize(n, [Codes].Count).Value
  deb(n + 1) = "TOTAL"
  deb(n + 1, 2).Resize(, [Codes].Count) = "=SUM(R[-" & n & "]C:R[-1]C)"
End With
With Me.UsedRange: End With 'actualise la barre de défilement verticale
ActiveWindow.ScrollRow = 1
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, [E9]) Is Nothing Then Worksheet_Activate
End Sub

  .[B2].Resize(IIf(n, n, 1)).Name = "Sheetlist" 'plage nommée