Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [C13].CurrentRegion) Is Nothing Then Exit Sub
Dim a, fer As Range, numero&, nom$, F As Worksheet, P As Range, sup As Range, i&, t, ub%, n&, rest()
a = Array("CA", "RTT", "CA/HP", "CA/FR", "(CA)", "(RTT)", "(CA/HP)", "(CA/FR)") 'liste à adapter
Set fer = [Feries]
numero = Application.Max(Sheets("Congés").[A:A]) + 1 'nécessaire pour la MFC
nom = Target
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'nouveau document
F.Parent.Date1904 = ThisWorkbook.Date1904 'calendrier
F.[A1].Resize(, 31) = [F11].Resize(, 31).Value 'adapter éventuellement
F.[A2].Resize(, 31) = Target(16, 4).Resize(, 31).Value 'adapter éventuellement
Set P = F.UsedRange
'---suppression des week-ends et jours fériés---
Set sup = Nothing
For i = 1 To 31
If Weekday(P(1, i), 2) > 5 Or Application.CountIf(fer, P(1, i)) _
Then Set sup = Union(P(1, i), IIf(sup Is Nothing, P(1, i), sup))
Next i
If Not sup Is Nothing Then sup.EntireColumn.Delete
'---analyse des congés---
t = P.Value2 'matrice, plus rapide
ub = UBound(t, 2)
For i = 1 To ub
If IsNumeric(Application.Match(t(2, i), a, 0)) Then
n = n + 1
ReDim Preserve rest(1 To 5, 1 To n)
rest(1, n) = numero
rest(2, n) = nom
rest(3, n) = t(1, i)
Do
i = i + 1
If i > ub Then Exit Do
Loop While t(2, i) = t(2, i - 1)
i = i - 1
rest(4, n) = t(1, i)
rest(5, n) = t(2, i)
End If
Next i
F.Parent.Close False 'suppression du nouveau document
'---restitution---
If n Then
With Sheets("Congés")
i = .Range("A" & .Rows.Count).End(xlUp)(2).Row
.Cells(i, 1).Resize(n, 5) = Application.Transpose(rest) 'maximum 65536 lignes
.Cells(i, 6).Resize(n) = "=RC[-2]-RC[-3]+1"
.Cells(i, 7).Resize(n) = "=NETWORKDAYS(RC[-4],RC[-3],Feries)"
.Activate
End With
End If
End Sub