Sub Demo()
Dim Ra As Range, Rw As Range
Application.ScreenUpdating = False
With Feuil1
VA = Application.Transpose(Range(.[E5], .[E4].End(xlDown)).Value)
R& = 4
Set Rw = .Cells(R, 11).CurrentRegion
Rw.Offset(1).Clear
If Rw.Columns.Count < 4 Then .Cells(1).Copy Rw(1): .[A1:C1].Copy Rw(1, 2)
For Each Rw In Range(.[A2], .Cells(.Rows.Count, 3).End(xlUp)).Rows
If Not IsNumeric(Rw.Cells(2).Value) Then
If Not IsError(Application.Match(Rw.Cells(1).Value, VA, 0)) Then
R = R + 1
Ra.Copy .Cells(R, 11)
Rw.Copy .Cells(R, 12)
End If
ElseIf Rw.Cells(1).Interior.ColorIndex = 15 Then
Set Ra = Rw.Cells(1)
End If
Next
End With
Set Ra = Nothing
End Sub