VBA---inscription de nombres.

Sub test()
Dim pl(), P As Range, Nb As Double, i As Long, j As Byte, k As Long, l As Long, Rep
Dim DerLig As Long
DerLig = Range("A" & Rows.Count).End(xlUp).Row
Nb = Range("F1").Value
For i = 1 To DerLig
Set P = Range(Cells(i, 1), Cells(i, 5))
Rep = Application.Match(Nb, P, 0)
 If Not IsError(Rep) Then
    ReDim Preserve pl(3, l)
        For j = 1 To 5
            If P(1, j) <> Nb Then
                pl(k, l) = P(1, j)
                k = k + 1
            End If
        
        Next j
       k = 0: l = l + 1
End If
Next i
Cells(2, 6).Resize(UBound(pl, 2) + 1, UBound(pl, 2)) = Application.Transpose(pl)
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
Set Target = Intersect(Target, [G1:J1]
If Target Is Nothing Then Exit Sub
Application.ScreenUpdating = False
[G2:K65536].ClearContents
If Application.Count([G1:J1]) = 0 Then Exit Sub
[F2].Formula = "=AND(IF(N($G$1),COUNTIF($A2:$E2,$G$1),TRUE),IF(N($H$1),COUNTIF($A2:$E2,$H$1),TRUE),IF(N($I$1),COUNTIF($A2:$E2,$I$1),TRUE),IF(N($J$1),COUNTIF($A2:$E2,$J$1),TRUE))"
Range("A1:E" & [A65536].End(xlUp).Row).AdvancedFilter xlFilterCopy, [F1:F2], [G2:K65536]
[F2:K2].ClearContents
Dim cel As Range
For Each cel In [G1:J1]
  [G3:K65536].Replace cel, "#N/A", LookAt:=xlWhole
Next
On Error Resume Next
[G3:K65536].SpecialCells(xlCellTypeConstants, 16).Delete xlToLeft
End Sub

[G3].CurrentRegion.Resize(, Application.Count([G1:J1])).Insert xlToRight

[G3].CurrentRegion.Resize(, Application.Count([G1:J1]) - 1).Insert xlToRight

=SOMMEPROD(SIGNE(NB.SI(A2:E2;G$1:J$1))+ESTVIDE(G$1:J$1))=4