Appliquer plusieurs filtres automatiques sur une base (2)

Sub Bouton1_Clic()
    Sheets("Base").Range("A7:F30").AdvancedFilter Action:=xlFilterCopy, _
                                                  CriteriaRange:=Sheets("Acceuil").Range("G1:J2"), CopyToRange:=Sheets("feuil1").Range("A7:F7"), Unique:=False
End Sub

Sub ListeDate()
    Dim i%, v$, dPlg, oCel As Range, oPlg As Range
    Dim dic As Object, LastLg As Integer
    Set dic = CreateObject("Scripting.Dictionary")
    LastLg = Range("A" & Rows.Count).End(xlUp).Row
    MsgBox "LastLg = " & LastLg
    Set oPlg = Range("A1:A" & LastLg)   'plage de données
    dPlg = oPlg.Value
    '-- Tri
    With oPlg.Parent.Sort
        .SortFields.Clear
        .SortFields.Add Key:=oPlg.Range("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        .SetRange oPlg
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .Apply
    End With
    On Error Resume Next
    
    '-- Récupérer les dates sans doublons
    For Each oCel In oPlg.Cells
        MsgBox "oCel = " & oCel & vbCrLf & _
        "Left oCel = " & Left(oCel, 10)
           dic(oCel.Value) = IIf(dic.Exists(Left(oCel.Value, 10)), dic(Left(oCel.Value, 10)) + 1, 1)
    Next oCel
    
    oPlg.Value = dPlg
    Set oPlg = Nothing
    Erase dPlg
    On Error GoTo 0
    Sheets("feuil1").Range("B2").Resize(dic.Count, 1) = Application.Transpose(dic.keys)
    
    '-- Plage nommée
    ActiveWorkbook.Names.Add Name:="MaListe", RefersTo:="=Feuil1!$B$2:$B$" & LastLg & ""
    '---------
    With [F2].Validation
        .Delete
        .Add Type:=xlValidateList, Formula1:="=MaListe"
        .IgnoreBlank = True
        .InCellDropdown = True
        .InputTitle = ""
        .ErrorTitle = ""
        .InputMessage = ""
        .ErrorMessage = ""
        .ShowInput = True
        .ShowError = True
    End With
End Sub