problème avec vba

bonjour tput le monde,

j'eprouve un certains problème avec appliqué mon vba voici celle-ci
Private Sub Worksheet_Activate()
[A1].Select
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
Sheets("Feuil2").Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"A1:A2"), CopyToRange:=Range("A3:H3"), Unique:=False
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim ListClients As Object
Dim DerLig As Long
Dim Cel As Range
If Target.Address = "$A$2" Then
Set ListClients = CreateObject("Scripting.Dictionary")
With Sheets("Feuil2")
DerLig = .[A65000].End(xlUp).Row
.Range("A2:M" & DerLig).Name = "base"
For Each Cel In .Range("A3:A" & DerLig)
ListClients.Item(Cel.Value) = Cel.Value
Next Cel
End With
For Each it In ListClients.items
tmp = tmp & "," & ListClients.Item(it)
Next it
tmp = Right(tmp, Len(tmp) - 1)
With Target.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
xlBetween, Formula1:=tmp
End With

End If
End Sub

mon problème c'est que le résultat se trouve ici

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$2" Then
Sheets("Feuil2").Range("base").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Range( _
"A1:A2"), CopyToRange:=Range("A3:H3"), Unique:=False

après avoir sélectionné la liste dans la cellule A2

merci bien de me guider....