XL 2010 Extraire et exporter onglets base de données

Sub Macro1()
    Dim Plg As Range
    Dim DerLig As Long
    Dim Sh As Worksheet, WbSource As Workbook, WbDestination As Workbook
    Dim Cel As Range
    'dictionary,menu outils,choisir références et activer microsoft scripting runtime dans la liste
    Dim Pays As New Dictionary    'Object 'Changer par le titre de la colonne
    Dim It
    Set WbSource = ThisWorkbook
    'Set Pays = CreateObject("Scripting.Dictionary") 'Changer par le titre de la colonne
    With Application
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    'For Each Sh In Sheets
    '    If Sh.Name <> "Base" Then Sh.Delete 'Nom de l'onglet de la Data Base
    'Next Sh
    With WbSource.Sheets("Base")
        DerLig = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Plg = .Range("A4:E" & DerLig)    ' Spécifier dernière colonne
        .[Z1] = .[B4]    'Colonne à Filtrer
        For Each Cel In .Range("B5:B" & DerLig)
            Pays(Cel.Value) = Cel.Value
        Next Cel
        For Each It In Pays.Items
            WbSource.Sheets.Add after:=Sheets(Sheets.Count)
            ActiveSheet.Name = It    'Left(It, 31)
            .[Z2] = It
            Plg.AdvancedFilter Action:=xlFilterCopy, _
                               CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=ActiveSheet.Range("A1"), Unique:=False
            Set WbDestination = Workbooks.Add
          WbSource.Sheets(It).UsedRange.Copy Destination:=WbDestination.Worksheets(1).Range("A1")
            WbDestination.Worksheets(1).Name = It
            WbDestination.SaveAs Filename:=WbSource.Path & "\" & It
            WbDestination.Close savechanges:=True
        Next It
        .Range("Z1:Z2").Clear
        .Select
    End With
End Sub

 Dim Pays As New Dictionary