Macro : filtre autant qu'il y a de nom et copier coller dans autant d'onglet

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, d As Object, a, i%, x$, j%
Set r = Intersect(Target, Range("A2:D" & Rows.Count), Me.UsedRange)
If r Is Nothing Then Exit Sub
Set r = Intersect(r.EntireRow, [A:A])
'---liste sans doublon des agences de Target---
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
For Each r In r 'si entrées multiples (copier-coller)
  If r <> "" Then d(r.Value) = ""
Next r
If d.Count = 0 Then Exit Sub
a = d.keys
'---création des feuilles---
On Error Resume Next
For i = 0 To UBound(a)
  If IsError(Sheets(a(i))) Then
    Application.ScreenUpdating = False
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = CStr(a(i))
  End If
Next i
'---classement des onglets créés---
If Not Application.ScreenUpdating Then
  For i = 2 To Sheets.Count 'on ne touche pas au 1er onglet
  x = LCase(Sheets(i).Name)
  For j = i + 1 To Sheets.Count
  If LCase(Sheets(j).Name) < x Then Sheets(j).Move Before:=Sheets(i)
  Next j, i
  Me.Activate
End If
End Sub

Private Sub Workbook_SheetActivate(ByVal Sh As Object)
With Sheets("Base")
  If Sh.Name = .Name Then Exit Sub
  Application.ScreenUpdating = False
  If Sh.FilterMode Then Sh.ShowAllData 'si la feuille est filtrée
  Cells.Delete 'RAZ
  .[E2] = "=A2=""" & Sh.Name & """" 'critère de filtrage
  .UsedRange.Resize(, 4).AdvancedFilter xlFilterCopy, .[E1:E2], Sh.[A1]
  .[E2] = ""
  Sh.Columns.AutoFit 'ajustement largeurs
End With
End Sub

Sub Retirer()
'se lance par Ctrl+R
Dim i%
Application.DisplayAlerts = False
For i = Sheets.Count To 2 Step -1
  If Application.CountIf([A:A], Sheets(i).Name) = 0 Then Sheets(i).Delete
Next
End Sub