XL 2016 Macro Filtrer + Copier Coller + Enregistrer

sebvosl · 5 Juin 2020

Bonjour,
N'y connaissant pas grand chose dans les macro VBA, j'aimerais réaliser une Macro qui :
1) Filtre sur les pays de la colonne A ''Country''
2) Colle le résultat dans un nouveau fichier > S'il y a 5 pays = 5 fichiers
3) Donne le nom des pays aux différents fichiers +"_YES" et me demande où je souhaite les enregistrer

Avec Enregistrer une macro, je parviens seulement à faire la 1ère étape
Si vous avez des idées je suis preneur !

Merci beaucoup votre aide
Seb

Papyty · 7 Juin 2020

Bonsoir sebvosl,

Sub à ingérer dans un module, voir le fichier en pièce jointe.

VB:

Sub ExportClasseur()
    Dim Unique As Object
    Dim DerLigne As Integer, DerColonne As Integer
    Dim Plage As Range, c As Range
    Dim Valeur
    
    Set Plage = Feuil1.UsedRange
    Set Unique = CreateObject("Scripting.Dictionary")
    If Feuil1.AutoFilterMode Then Feuil1.AutoFilterMode = False
    DerLigne = Plage.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
    DerColonne = Plage.Cells(1, Rows(1).Cells.Count).End(xlToLeft).Column
    For Each c In Plage.Range(Cells(2, 1), Cells(DerLigne, 1))
        If Not Unique.Exists(c.Value) Then Unique.Add c.Value, c.Value
    Next c
    For Each Valeur In Unique.keys
        Plage.Range(Cells(1, 1), Cells(DerLigne, DerColonne)).AutoFilter Field:=1, Criteria1:=Valeur
        Workbooks.Add
        Plage.Copy [a1]
        Application.Dialogs.Item(xlDialogSaveAs).Show Valeur & "_YES"
        ThisWorkbook.Activate
        Feuil1.ShowAllData
    Next
End Sub

Bonne soirée

Papyty

sebvosl · 9 Juin 2020

Wouah impressionnant. Merci beaucoup ! C'est exactement ce je souhaitais.

J'ai tenté de rajouter ce codde ci-dessous, à la fin pour fermer les classeurs générés. Mais comment puis-je adapter ce code automatiquement au nombre de nouveaux classeurs créés ?

Workbooks(Nom_Classeur).Close True

Par ailleurs, mon fichier d'origine contenant plusieurs onglets, j'ai tenté d'ajouter ceci au début du code pour lui notifier dans quel onglet (il se nomme ''COTATION_YES'') travailler mais ce ne fonctionne pas.
Comment lui préciser dans quel onglet appliquer le code que vous avez créé ?

Sheets("COTATION_YES").Select

Merci pour votre aide,

Bien à vous,
Sébastien

Papyty · 9 Juin 2020

Bonjour sebvosl,

Sub modifiée.

VB:

Sub ExportClasseur()
    Dim Unique As Object
    Dim DerLigne As Integer, DerColonne As Integer
    Dim Plage As Range, c As Range
    Dim Valeur
    
    Set Plage = ThisWorkbook.Worksheets("COTATION_YES").UsedRange
    Set Unique = CreateObject("Scripting.Dictionary")
    If ThisWorkbook.Worksheets("COTATION_YES").AutoFilterMode Then ThisWorkbook.Worksheets("COTATION_YES").AutoFilterMode = False
    DerLigne = Plage.Cells(Columns(1).Cells.Count, 1).End(xlUp).Row
    DerColonne = Plage.Cells(1, Rows(1).Cells.Count).End(xlToLeft).Column
    For Each c In Plage.Range(Cells(2, 1), Cells(DerLigne, 1))
        If Not Unique.Exists(c.Value) Then Unique.Add c.Value, c.Value
    Next c
    For Each Valeur In Unique.keys
        Plage.Range(Cells(1, 1), Cells(DerLigne, DerColonne)).AutoFilter Field:=1, Criteria1:=Valeur
        Workbooks.Add
        Plage.Copy [a1]
        Application.Dialogs.Item(xlDialogSaveAs).Show Valeur & "_YES"
        ActiveWorkbook.Close savechanges:=False
        ThisWorkbook.Activate
        ThisWorkbook.Worksheets("COTATION_YES").ShowAllData
    Next
End Sub

Bonne continuation.

Papyty.

sebvosl · 10 Juin 2020

C'est parfait, un grand merci

Bien à vous,
Sébastien

XL 2016 Macro Filtrer + Copier Coller + Enregistrer

sebvosl

XLDnaute Nouveau

Pièces jointes

Papyty

XLDnaute Nouveau

Pièces jointes

sebvosl

XLDnaute Nouveau

Papyty

XLDnaute Nouveau

Pièces jointes

sebvosl

XLDnaute Nouveau

Discussions similaires