Macro qui copie automatique vers une autre feuille selon ce que contient la cellule

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, Range("B2,D2")) Is Nothing Then Exit Sub
Cancel = True
Filtre Target
End Sub

Sub Filtre(Target As Range)
Dim F1 As Worksheet, F2 As Worksheet, plage As Range
Set F1 = Sheets("Tous les projets")
Set F2 = Sheets("Projets apprenti")
On Error Resume Next 'si le nom n'est pas trouvé
F1.[B:D].Replace Target, 1, LookAt:=xlWhole
Set plage = F1.[B:D].SpecialCells(xlCellTypeConstants, 1)
F1.Cells.Copy F2.Cells 'pour les dimensions des colonnes
F2.Cells.Clear
Union(F1.Rows(1), plage.EntireRow).Copy F2.[A1]
F2.[B2:D65536].SpecialCells(xlCellTypeConstants, 2).ClearContents
F2.[B:D].Replace 1, Target
F1.[B:D].Replace 1, Target
F2.Activate 'facultatif
End Sub

Sub Filtre()
Dim F1 As Worksheet, F2 As Worksheet
Dim Target As String, plage As Range
Set F1 = Sheets("Tous les projets")
Set F2 = Sheets("Projets apprenti")
Target = Sheets("Menu").DrawingObjects(Application.Caller).Text
On Error Resume Next 'si le nom n'est pas trouvé
F1.[E:G].Replace Target, 1, LookAt:=xlWhole
Set plage = F1.[E:G].SpecialCells(xlCellTypeConstants, 1)
F1.Cells.Copy F2.Cells 'pour les dimensions des colonnes
F2.Cells.Clear
F2.DrawingObjects.Delete 'suppression des objets
Union(F1.Range("1:4"), plage.EntireRow).Copy F2.[A1]
F2.[E5:G65536].SpecialCells(xlCellTypeConstants, 2).ClearContents
F2.[E:G].Replace 1, Target
F1.[E:G].Replace 1, Target
F2.Activate 'facultatif
End Sub

F2.Unprotect "mdp" 'votre mot de passe
'-----
F2.Protect "mdp"