Sub Liste()
Dim a, F1 As Worksheet, F2 As Worksheet, nlig&, P As Range, ncol%, rest()
Dim fer As Range, F As Worksheet, i&, Q As Range, sup As Range, j%, t, ub%, n&
a = Array("CA", "RTT", "CF", "CHS") 'liste à adapter, pas besoin des *
Set F1 = Feuil1 'CodeName de la feuille Planning
Set F2 = Feuil6 'CodeName de la feuille Congés
nlig = Application.Match("zzz", F1.[C:C]) - 10 'à adapter
If nlig < 2 Then GoTo 1
Set P = Intersect(F1.[C11].Resize(nlig, F1.Columns.Count - 2), F1.UsedRange)
ncol = P.Columns.Count
ReDim rest(1 To nlig * ncol, 1 To 4)
Set fer = [Férié]
Application.ScreenUpdating = False
Set F = Workbooks.Add.Sheets(1) 'nouveau document
For i = 2 To nlig
'---tableau de 2 lignes---
F.[A1].Resize(, ncol) = P.Rows(1).Value
F.[A2].Resize(, ncol) = P.Rows(i).Value
Set Q = F.[A1].Resize(2, ncol)
'---suppression des week-ends et jours fériés---
Set sup = Nothing
For j = 2 To ncol
If Weekday(Q(1, j), 2) > 5 Or Application.CountIf(fer, Q(1, j)) _
Then Set sup = Union(Q(1, j), IIf(sup Is Nothing, Q(1, j), sup))
Next j
If Not sup Is Nothing Then sup.EntireColumn.Delete
'---nouvelle analyse---
t = Q 'matrice, plus rapide
ub = UBound(t, 2)
For j = 2 To ub
If IsNumeric(Application.Match(t(2, j), a, 0)) Then
n = n + 1
rest(n, 1) = t(2, 1)
rest(n, 2) = t(1, j)
Do
j = j + 1
If j > ub Then Exit Do
If t(2, j) <> t(2, j - 1) Then Exit Do
Loop
j = j - 1
rest(n, 3) = t(1, j)
rest(n, 4) = t(2, j)
End If
Next j
Next i
F.Parent.Close False 'suppression du nouveau document
If n Then F2.[A3].Resize(n, 4) = rest 'restitution
1 F2.Range("A" & n + 3 & ":D" & F2.Rows.Count).ClearContents
End Sub