XL 2013 Exporter Onglets selon critère du nom

[bast0504]

Bonjour à tous,

Je possède la macro suivante qui me permet d'extraire des données par onglets et par pays

Je souhaite inclure dans cette macro un code qui puisse en plus me permettre d'extraire dans des classeurs individuels ces onglets crées sans extraire les onglets "Autres" et les enregistrés sur mon bureau.

Seuls les onglets dont le nom est un pays doivent être exportés, noms listés dans la colonne B de l'onglet Base

Comment je pourrais exporter ces onglets selon ce critère?

Merci par avance pour votre aide
Cordialement

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("A4"), Unique:=False
            Set WbDestination = Workbooks.Add
          WbSource.Sheets(It).UsedRange.Copy Destination:=WbDestination.Worksheets(1).Range("A4")
            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

 

[Robert]

Bonjour Bast, bonjour le forum,

Peut-être comme ça :

Sub Macro2()
Dim B As Worksheet 'déclare la variable B (onglet Base)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim X As Byte 'déclare la variable X (incrément)
Dim NO As Worksheet 'déclare la variable NO (Nouvel Onglet)
Dim J As Byte 'déclare la variable J (incrément)
Dim K As Integer 'déclare la variable K (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)

Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set B = Worksheets("Base") 'définit l'onglet B
TV = B.Range("A4").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 2)) = "" 'alimente le dictionnaire D avec les données en colonne 2 du tableau des valeurs TV (les pays)
Next I 'prochaine ligne de la boucle
TMP = D.Keys 'récupère dans le tableau temporaire TMP la liste des éléments du dictionnaire D sans doublons
For X = 0 To UBound(TMP) 'boucle 1 : sur tous les éléments (Pays) du tableau temporaire TMP
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set NO = Worksheets(TMP(X)) 'définit l'onglet NO (génère une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Sheets.Add After:=Sheets(Sheets.Count) 'ajoute un nouvel onglet en dernière position
        ActiveSheet.Name = TMP(X) 'renomme cet onglet
        Set NO = ActiveSheet 'définit l'onglet NO
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    NO.Range("A4").CurrentRegion.ClearContents 'efface d'éventuelles anciennes donnée de l'onglet NO
    NO.Range("A4").Resize(1, UBound(TV, 2)).Value = Application.Index(TV, 1) 'envoie les en-têtes dans A4 redimensionnée
    K = 1 'initialise la variable K
    For I = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
        If TV(I, 2) = TMP(X) Then 'condition : si la donnée en colonne 2 de TV est égale au pays dans TMP(X)
            'redimensionne le tableau des lignes TL (autant de lignes que TV a de colonnes, K colonnes)
            ReDim Preserve TL(1 To UBound(TV, 2), 1 To K)
            For J = 1 To UBound(TV, 2) 'boucle 3 : sur toutes les lignes J du tableau des lignes TL
                TL(J, K) = TV(I, J) 'récupère dans la ligne J de TL la donnée en colonne J de TV (= Transposition)
            Next J 'prochaine ligne de la boucle 3
            K = K + 1 'incrémente K (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next I 'prochaine ligne de la bouce 2
    'si K est supérieure à 1, renvoie dans A5 redimentionnée de l'onglet NO, le tableau TL transposé
    If K > 1 Then NO.Range("A5").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL)
    Erase TL 'vide le tableau TL
    NO.Copy 'copie l'onglet NO dans un nouveau classeur
    Set CD = ActiveWorkbook 'définit le classeur CD
    Application.DisplayAlerts = False 'empêche les messages d'Excel
    CD.SaveAs ThisWorkbook.Path & "\" & TMP(X) & ".xlsx", 51 'enregistre-sous le claseur CD
    Application.DisplayAlerts = True 'autorise les messages d'Excel
    CD.Close SaveChanges:=True 'ferme le classeur CD en enregistranrt les modifications
Next X 'prochain pays de la boucle 1
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub