Private Sub Worksheet_SelectionChange(ByVal R As Range)
Range("B2:C" & Rows.Count).Validation.Delete 'RAZ
Set R = ActiveCell
If R.Row = 1 Or Cells(R.Row, 1) = "" Then Exit Sub
If Not Cells(R.Row, 1) Like "####" Or Val(Right(Cells(R.Row, 1), 2)) = 0 Or Val(Right(Cells(R.Row, 1), 2)) > 12 _
Then MsgBox "Année et/ou mois non valides !", 48: Exit Sub
Dim d As Object, dat As Date, sem As Byte, x$
If R.Column = 2 Then
If R(1, 0) <> "" Then
Set d = CreateObject("Scripting.Dictionary")
For dat = DateSerial("20" & Left(R(1, 0), 2), Right(R(1, 0), 2), 1) To DateSerial("20" & Left(R(1, 0), 2), Right(R(1, 0) + 1, 2), 0)
sem = Application.IsoWeekNum(dat)
If Not d.exists(sem) Then d(sem) = "": x = x & "," & Format(sem, "\S00")
Next
R.Validation.Add xlValidateList, Formula1:=Mid(x, 2)
End If
ElseIf R.Column = 3 Then
If R(1, -1) <> "" And R(1, 0) <> "" Then
For dat = DateSerial("20" & Left(R(1, -1), 2), Right(R(1, -1), 2), 1) To DateSerial("20" & Left(R(1, -1), 2), Right(R(1, -1) + 1, 2), 0)
sem = Application.IsoWeekNum(dat)
If Format(sem, "\S00") = R(1, 0) Then x = x & "," & Application.Proper(Format(dat, "ddd dd/mm/yyyy"))
Next
R.Validation.Add xlValidateList, Formula1:=Mid(x, 2)
End If
End If
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
Dim a As Range
Application.EnableEvents = False 'désactive les évènements
On Error Resume Next
With ListObjects(1).DataBodyRange 'tableau Excel
For Each a In Intersect(Target, .Columns(1)).Areas
a.Offset(, 1).Resize(, 2) = "" 'effacements en colonnes B et C
Next
For Each a In Intersect(Target, .Columns(2)).Areas
a.Offset(, 1) = "" 'effacements en colonne C
Next
If Application.CountBlank(.Columns(1)) Then
.Sort .Columns(4), xlAscending, Header:=xlYes 'tri pour regrouper et accélérer
Intersect(.SpecialCells(xlCellTypeBlanks).EntireRow, .Cells).Delete xlUp
End If
If .Cells(1, 4).Formula <> "=IFERROR(--RIGHT(C2,10),"""")" Then .Cells(1, 4) = "=IFERROR(--RIGHT(C2,10),"""")"
End With
Application.EnableEvents = True 'réactive les évènements
End Sub
