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.
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
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
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