XL 2010 Extraire et exporter onglets base de données

[bast0504]

Bonjour à tous

J'utilise la macro suivante pour extraire mes données par onglets selon un critère (dans mon cas pays)

Il semble que cette macro supprime les autres onglets existants au moment de l'extraction des données par onglets

Comment je peux mettre à jour cette macro afin :
- D'extraire mes données par onglets sans supprimer les autres onglets existants
- Exporter les onglets crées dans des classeurs individuels , sans exporter les autres onglets existants

Merci par avance

Sub Macro1()
Dim Plg As Range
Dim DerLig As Long
Dim Sh As Worksheet
Dim Cel As Range
Dim Pays As Object 'Changer par le titre de la colonne
Dim It
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 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
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = Left(It, 31)
        .[Z2] = It
        Plg.AdvancedFilter Action:=xlFilterCopy, _
            CriteriaRange:=.Range("Z1:Z2"), CopyToRange:=ActiveSheet.Range("A1"), Unique:=False
    Next It
    .Range("Z1:Z2").Clear
    .Select
End With
End Sub

 

[Bebere]

bonjour
la boucle avec sh.delete
lire pour dictionary,les classeurs sont sauvés ds le dossier du classeur wbsource
testé sous excel2010

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

 

[bast0504]

Bonjour Bebere

Merci beaucoup pour cette proposition qui fonctionne sous 2010

Je viens de rendre compte que sous 2013, la macro bloque sur la ligne suivante

 Dim Pays As New Dictionary

Comment je pourrais mettre à jour cette ligne pour éviter que la macro ne se bloque ?

Merci par avance

 

[bast0504]

Bonjour Bebere

Je viens de voir ton commentaire dans le code
En activant l'option cela fonctionne correctement

Merci pour ton aide