formule matricielle trop long d execution

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("E4")) Is Nothing Then
    Range("B6:B" & Range("B65535").End(xlUp).Row + 1).ClearContents
ligne = 6
With Sheets("test3")
For i = 3 To .Range("IV5").End(xlToLeft).Column
If .Cells(5, i).Value <> Target And .Cells(6, i).Value <> [E3] Then
GoTo fin
End If
For j = 7 To .Cells(65535, i).End(xlUp).Row
Cells(ligne, 2) = .Cells(j, i)
ligne = ligne + 1
Next j
fin:
Next i
End With
End If
End Sub

If .Cells(5, i).Value <> Target And .Cells(6, i).Value <> [E3] Then

Private Sub Worksheet_Change(ByVal Cible As Range)
Dim ligne&, i&, a, b, c&, CelA As Range, CelB As Range, Plg As Range
    Set Plg = Range("E3:E4") '*** Paramètres de recherche ***
    If Not Intersect(Cible, Plg) Is Nothing Then
        Set CelA = Range("B5") '*** Cellule d'intitulé des résultats ***
        ligne = CelA.Row + 1
        a = Plg(1).Value
        b = Plg(2).Value
        With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
        With Range(CelA, Cells(Rows.Count, CelA.Column).End(xlUp))
            If .Rows.Count > 1 Then .Resize(.Rows.Count - 1, 1).Offset(1).ClearContents
        End With
        With Sheets("test3") '*** Feuille de données ***
            Set CelB = .Range("C5") '*** Haut gauche de la plage de données ***
            c = CelB.Row + 1
            For i = CelB.Column To .Cells(c - 1, .Columns.Count).End(xlToLeft).Column
                If .Cells(c - 1, i).Value = b And .Cells(c, i).Value = a Then
                    Set Plg = .Range(.Cells(c, i), .Cells(.Rows.Count, i).End(xlUp))
                    If Plg.Rows.Count > 1 Then
                        Set Plg = Plg.Resize(Plg.Rows.Count - 1, 1).Offset(1)
                        Cells(ligne, CelA.Column).Resize(Plg.Rows.Count, 1).Value = Plg.Value
                        ligne = ligne + Plg.Rows.Count
                    End If
                End If
            Next i
        End With
        With Application: .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True: End With
    End If
End Sub

Private Sub Worksheet_Change(ByVal Cible As Range)
Dim ligne&, i&, a, b, c&, CelA As Range, CelB As Range, Plg As Range, x
    Set Plg = Range("E3:E4") '*** Paramètres de recherche ***
    If Not Intersect(Cible, Plg) Is Nothing Then
        Set CelA = Range("B5") '*** Cellule d'intitulé des résultats ***
        ligne = CelA.Row + 1
        a = Plg(1).Value
        b = Plg(2).Value
        With Application: .ScreenUpdating = False: .EnableEvents = False: .Calculation = xlCalculationManual: End With
        With Range(CelA, Cells(Rows.Count, CelA.Column).End(xlUp))
            If .Rows.Count > 1 Then .Resize(.Rows.Count - 1, 1).Offset(1).ClearContents
        End With
        With Sheets("test3") '*** Feuille de données ***
            Set CelB = .Range("C5") '*** Haut gauche de la plage de données ***
            c = CelB.Row + 1
            For i = CelB.Column To .Cells(c - 1, .Columns.Count).End(xlToLeft).Column
                If .Cells(c - 1, i).Value = b And .Cells(c, i).Value = a Then
                    Set Plg = .Range(.Cells(c, i), .Cells(oMax(c - 1, .Cells(.Rows.Count, i).End(xlUp).Row), i))
                    If Plg.Rows.Count > 1 Then
                        If Not IsEmpty(Plg(2)) Then
                            Set Plg = Plg.Resize(Plg.Rows.Count - 1, 1).Offset(1)
                            Cells(ligne, CelA.Column).Resize(Plg.Rows.Count, 1).Value = Plg.Value
                            ligne = ligne + Plg.Rows.Count
                        End If
                    End If
                End If
            Next i
        End With
        With Application: .Calculation = xlCalculationAutomatic: .EnableEvents = True: .ScreenUpdating = True: End With
    End If
End Sub

Private Function oMax(x&, y&)
    oMax = ((x + y) + Abs(x - y)) / 2
End Function