Split d'un fichier Excel en plusieurs fichiers (sur critères) - Power Query

Bonjour le forum,

J'utilise actuellement un fichier de consolidation regroupant le travail de nombreuses filiales. Je souhaiterais générer autant de fichiers (1 par filiale) contenant les lignes de mon fichier de consolidation correspondant au travail réalisé par la filiale. De plus, je souhaiterais nommer chaque fichier par l'intitulé de la filiale.
Au sein du fichier en PJ, vous trouverez en fluo la colonne permettant d'identifier le nom des différentes filiales.

13classeur1.xlsx (20.02 Ko)

Merci d'avance pour vos conseils :)
Tdudoret29

RE

Je t'ai déjà indiqué dans ce fil https://forum.excel-pratique.com/excel/macro-comparaison-differences-entre-2-fichiers-143438#p881783 que je ne souhaite pas de MP non sollicité

Pour éclater le fichier en n fichiers il faut utiliser VBA : PowerQuery ne gère pas cela.

Donc un code avec extraction par filtre avancé puis enregistrement de l’onglet d'extraction dans un nouveau classeur.

Il y a plein d'exemples similaires

Bonjour,

Une proposition à adapter.

Les fichiers crées sont enregistrés dans le répertoire courant.

Cdlt

17tdudoret29.xlsm (30.80 Ko)
Option Explicit

Public Sub CreateBooks()
Dim wb As Workbook, wb2 As Workbook
Dim ws As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim strPath As String, nm As String
Dim lastRow As Long

    Application.ScreenUpdating = False

    Set wb = ActiveWorkbook
    strPath = wb.Path & Application.PathSeparator
    Set ws = wb.Worksheets("Données")
    Set lo = ws.ListObjects("Données")
    If lo.ShowAutoFilter Then lo.AutoFilter.ShowAllData

    Set ws2 = wb.Worksheets.Add(after:=wb.Worksheets(Worksheets.Count))
    ws2.Name = "tmp"

    With ws2
        lo.ListColumns(3).Range.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), Unique:=True
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        For Each Cell In .Cells(2, 1).Resize(lastRow - 1)
            nm = VBA.Replace(Cell.Value, " ", "_")
            lo.Range.AutoFilter Field:=3, Criteria1:=Cell.Value
            Set ws3 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With ws3
                .Name = nm
                With .Cells(1)
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False
                    .Select
                End With
                .ListObjects.Add(xlSrcRange, Cells(1).CurrentRegion, , xlYes).Name = "T_" & nm
            End With
            With ws3.Parent
                .SaveAs strPath & Cell.Value & ".xlsx", 51
                .Close False
            End With
        Next Cell
    End With

    lo.Range.AutoFilter Field:=3

    Application.DisplayAlerts = False
    wb.Worksheets("tmp").Delete
    Application.DisplayAlerts = True

End Sub

Merci beaucoup ! Je vais essayer avec cette macro :)

@jean-eric

Rebonjour,

Serait-il possible de détailler les principales étapes de cette macro ? Ça me permettrait de constituer un petit user guide pour la capitalisation de mon fichier :)

Merci d'avance,

Bonjour,

Des explications et une petite modification de la procédure.

Cdlt

8tdudoret29.xlsm (30.28 Ko)
Option Explicit

Public Sub CreateBooks()
'Déclaration des variables
Dim wb As Workbook
Dim ws2 As Worksheet, ws3 As Worksheet
Dim lo As ListObject
Dim Cell As Range
Dim strPath As String, nm As String
Dim lastRow As Long

    Application.ScreenUpdating = False

    Set wb = ThisWorkbook
    'Chemin du classeur courant
    strPath = wb.Path & Application.PathSeparator
    Set lo = Range("Données").ListObject
    If lo.ShowAutoFilter Then lo.AutoFilter.ShowAllData
    'Création feuille temporaire
    Set ws2 = wb.Worksheets.Add(after:=wb.Worksheets(Worksheets.Count))

    With ws2
        'On crée la liste unique des entités
        lo.ListColumns(3).Range.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=.Range("A1"), Unique:=True
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        'pour chaque élément de la liste unique
        For Each Cell In .Cells(2, 1).Resize(lastRow - 1)
            'Nom feuille (et tableau)
            nm = VBA.Replace(Cell.Value, " ", "_")
            'Filtre du tableau Données avec élément
            lo.Range.AutoFilter Field:=3, Criteria1:=Cell.Value
            'Création nouveau classeur avec une feuille unique
            Set ws3 = Workbooks.Add(xlWBATWorksheet).Worksheets(1)
            'Copie des données filtrées
            lo.Range.SpecialCells(xlCellTypeVisible).Copy
            With ws3
                'Nom de la feuille
                .Name = nm
                'Restitution des données filtrées dans la feuile
                With .Cells(1)
                    .PasteSpecial xlPasteColumnWidths
                    .PasteSpecial xlPasteValuesAndNumberFormats
                    Application.CutCopyMode = False
                    .Select
                End With
                'Mise des données sous forme de tableau (structuré)
                'Nom tableau = T_Nom_feuille
                .ListObjects.Add(xlSrcRange, Cells(1).CurrentRegion, , xlYes).Name = "T_" & nm
            End With
            'Enregistrement du classeur dans le répertoire courant
            With ws3.Parent
                .SaveAs strPath & Cell.Value & ".xlsx", 51
                .Close False
            End With
        Next Cell
    End With

    'Suppression filtre tableau Données
    lo.Range.AutoFilter Field:=3
    'Suppression de la feuille temporaire
    Application.DisplayAlerts = False
    ws2.Delete

End Sub

Un énorme merci !

Très bon week-end à vous,

Tdudoret29

Rechercher des sujets similaires à "split fichier fichiers criteres power query"