Créer une macro pour scinder un fichier Excel sur plusieurs fichiers
Bonjour tout le monde,
Pièce-jointe : capture d'écran
Tout d'abord, j'espère que vous vous portez bien et votre confinement se passe très bien. Protégez-vous bien, c'est le plus important.
Concernant ma demande, je souhaite créer une macro pour scinder/splitter un fichier excel sur 18 fichiers filtrés par valeur de la colonne A (périmètre). J'explique !
La macro se focalise sur la colonne A pour la filtrer et elle me donne un fichier pour chaque valeur de la colonne, c'est-à-dire 18 fichiers (18 valeurs dans la colonne). Est-ce cela est faisable ? avez-vous un code vba à me communiquer ?
Merci beaucoup,
Bien cordialement,
Bonjour et
Sans fichier, je te réponds par une application générique
https://www.excel-pratique.com/fr/telechargements/utilitaires/dispatcher-compiler-excel-no466
Bonjour le fil, bonjour le forum,
Oui Steelson a raison ce n'est pas un forum PhotoShop ! Un fichier vaut meux qu'une capture d'écran !... Le code ci-dessous va te créer autant de fichiers qu'il y a de filtres, dans le même dossier que le fichier original. Les fichiers sont fermés au fur et à mesure :
Sub Macro1()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
Set OS = CS.Worksheets("Feuil1") 'défini l'onglet source OS (à adapter à ton cas)
Set PL = OS.Range("A1").CurrentRegion 'définit la plage PL
TV = PL 'définit la 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, 1)) = "" 'alimente le dictionnaire D avec les données en colonne 1 de TV
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 doublon
For I = 0 To UBound(TMP) 'boucle sur les éléments du tableau temporaire TMP
PL.AutoFilter 'supprime le filtre automatique
PL.AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la plage PL avec TMP(I) comme critère
OS.Copy 'copy l'onglet OS dans un classeur vierge
Set CD = ActiveWorkbook 'définit le classeur destination CD
CD.Worksheets(1).Name = TMP(I) 'renomme le premier onglet du classeur destination avec TMP(I)
CD.SaveAs CA & TMP(I), FileFormat:=51 'enregistre sous le classeur destination dans le même dossier que CS et avec TMP(I) comme nom
CD.Close False 'ferme le classeur destination
Next I 'prochain élément de la boucle
PL.AutoFilter 'supprime le filtre automatique
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
Bonjour Steelson, Bonjour Thauthème,
Merci pour vos réponses. Malheureusement, je n'ai pas réussi jusqu'à maintenant.
Je partage avec vous le fichier (lien ci-dessous), ça sera plus simple : onglet data, filtrer grâce à la macro avec la colonne A et avoir automatiquement 18 fichiers qui contiennent chacun d'eux une seule valeur de cette colonne.
Lien :
Pouvez-vous voir de votre côté si ça marche ? et dites-moi si vous avez réussi à avoir le fichier (problème de volume) ?
Merci d'avance de votre aide,
Voilà le code vba que j'avais fait. Merci infiniment,
Sub Suivi()
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Integer 'déclare la variable I (Incrément)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim Data1 As Variant 'déclare la variable Data1 (tableau TeMPoraire)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
Set OS = CS.Worksheets("data") 'défini l'onglet source OS (à adapter à ton cas)
Set PL = OS.Range("A1").CurrentRegion 'définit la plage PL
TV = PL '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, 1)) = "" 'alimente le dictionnaire D avec les données en colonne 1 de TV
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 doublon
For I = 0 To UBound(TMP) 'boucle sur les éléments du tableau temporaire TMP
PL.AutoFilter 'supprime le filtre automatique
PL.AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la plage PL avec TMP(I) comme critère
OS.Copy 'copy l'onglet OS dans un classeur vierge
Set CD = ActiveWorkbook 'définit le classeur destination CD
CD.Worksheets(1).Name = Data1(I) 'renomme le premier onglet du classeur destination avec DATA1(I)
CD.SaveAs CA & Data1(I), FileFormat:=51 'enregistre sous le classeur destination dans le même dossier que CS et avec TMP(I) comme nom
CD.Close False 'ferme le classeur destination
Next I 'prochain élément de la boucle
PL.AutoFilter 'supprime le filtre automatique
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
End Sub
Re,
J'ai réussir à ouvrir ton fichier absolument pas anonymiser !...
Il y avait encore quelques truc à modifier et ça mettra pas mal de temps à tourner...
Sub Macro1()
Dim Deb As Double
Dim CS As Workbook 'déclare la variable CS (Classeur Source)
Dim CA As String 'déclare la variable CA (Chemin d'Accès)
Dim OS As Worksheet 'déclare la variable OS (Onglet Source)
Dim PL As Range 'déclare la variable PL (PLage)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim I As Long 'déclare la variable I (Incrément)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim TMP As Variant 'déclare la variable TMP (tableau TeMPoraire)
Dim CD As Workbook 'déclare la variable CD (Classeur Destination)
Dim Fin As Double
Deb = Timer 'lance le chronométarge
Application.ScreenUpdating = False 'masque les rafraîchissements d'écran
Set CS = ThisWorkbook 'définit le classeur source CS
CA = CS.Path & "\" 'définit le chemin d'accès CA
Set OS = CS.Worksheets("data") 'défini l'onglet source OS (à adapter à ton cas)
Set PL = OS.Range("A1").CurrentRegion 'définit la plage PL
TV = Application.Intersect(OS.Columns(1), PL) 'définit la 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, 1)) = "" 'alimente le dictionnaire D avec les données en colonne 1 de TV
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 doublon
For I = 0 To 0 'UBound(TMP) 'boucle sur les éléments du tableau temporaire TMP
PL.AutoFilter 'supprime le filtre automatique
PL.AutoFilter Field:=1, Criteria1:=TMP(I) 'filtre la plage PL avec TMP(I) comme critère
OS.Copy 'copy l'onglet OS dans un classeur vierge
Set CD = ActiveWorkbook 'définit le classeur destination CD
CD.Worksheets(1).Name = Data1(I) 'renomme le premier onglet du classeur destination avec DATA1(I)
CD.SaveAs CA & Data1(I), FileFormat:=51 'enregistre sous le classeur destination dans le même dossier que CS
CD.Close False 'ferme le classeur destination
Next I 'prochain élément de la boucle
PL.AutoFilter 'supprime le filtre automatique
Application.ScreenUpdating = True 'affiche les rafraîchissements d'écran
Fin = Timer 'stoppe le chronométrage
MsgBox "Données traitées en " & Fin - Deb & " secondes !" 'message
End Sub
Ree,
J'ai essayé, mais il me donne ce message d'erreur (pièce-jointe) avant d'avoir le seul fichier (le premier : 750528).
Ce que je souhaite avoir c'est :
- 18 fichiers ouverts d'un coup : comme ce fichier-là et aussi les 17 restants
- Sans la dernière valeur de la colonne "vides" : que les 18 valeurs/fichiers
- Garder aussi le 2ème onglet "Explications" si c'est possible,
Merci encore de votre aide,
Pourquoi autant de colonnes ?
Il faut épurer ...
Je veux bien, mais j'en ai absolument besoin.
Cela est faisable ?
Merci,
1ère question, tu sélectionnes l'en-tête colonne A
2ème question, tu sélectionnes un dossier pour la sauvegarde
bonjour ThauThème
Option Explicit
Public critere%
Sub dispatcher()
Dim Tbl As Variant, data As Variant, i As Long
Dim dico1 As Object, cle1 As Variant, result1 As Variant
Dim wb As Excel.Workbook
Dim MonRepertoire, Repertoire As FileDialog, racine As String
Dim colonne$
'colonne = Application.InputBox("Entrez la colonne servant de critère de dispatching : ", "Saisie en texte (i.e : A B ...)", Type:=2)
'critere = ActiveSheet.Columns(colonne).Column
UserForm1.Show
If critere = 0 Then Exit Sub
racine = Split(ThisWorkbook.Name, ".")(0)
Set Repertoire = Application.FileDialog(msoFileDialogFolderPicker)
Application.FileDialog(msoFileDialogFolderPicker).Title = "Choix du répertoire de stockage des fichiers générés"
Repertoire.Show
If Repertoire.SelectedItems.Count = 0 Then Exit Sub
MonRepertoire = Repertoire.SelectedItems(1)
data = Cells(Rows.Count, 1).End(xlUp).CurrentRegion
Set dico1 = CreateObject("Scripting.Dictionary")
For i = LBound(data) + 1 To UBound(data) ' hors en-tête
dico1(data(i, critere)) = ""
Next
Application.ScreenUpdating = False
For Each cle1 In dico1.Keys
result1 = filtreArray(data, critere, cle1)
Set wb = Workbooks.Open(ThisWorkbook.Path & "\" & "Model.xlsx")
wb.Sheets(1).Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(UBound(result1, 1), UBound(result1, 2)) = result1
wb.SaveAs (MonRepertoire & "\" & racine & "_" & cle1 & ".xlsx")
wb.Close
Set wb = Nothing
Next
Application.ScreenUpdating = True
MsgBox "Terminé, fichiers sauvegardés sous """ & MonRepertoire & "\" & """ !"
End Sub
et
Function filtreArray(Tbl, col, param)
Dim i As Long, j As Long, k As Long, n As Long
For i = 1 To UBound(Tbl)
If Tbl(i, col) = param Then n = n + 1
Next i
Dim temp: ReDim temp(1 To n, 1 To UBound(Tbl, 2))
j = 0
For i = 1 To UBound(Tbl)
If Tbl(i, col) = param Then
j = j + 1
For k = 1 To UBound(Tbl, 2)
temp(j, k) = Tbl(i, k)
Next k
End If
Next i
filtreArray = temp
End Function
Tu as aussi dans le fichier un recompilateur des retours de fichiers
Le Model.xlsx contient justement la seconde page.
Tu peux enlever les premières lignes du fichier de base.
Ce que tu m'as renvoyé ne contient pas la modèle.
3/ Ne pas créer un autre fichier excel ouvert "Model", il ne sert à rien à mon avis
- 1/ Peux-tu enlever la manip de la capture 1 ? Exécuter directement sans sélectionne la colonne A
- 2/ Il me donne toujours l'erreur (capture 2)
Merci d'avance,
Tu fais comme tu veux ...
Le fichier modèle permet de transporter facilement le second onglet
Ton fichier n'a pas de macros
Peux-tu regarder STP le message d'erreur ?
Voilà le lien du fichier avec la macro :
- Il reste 2 valeurs à sauvegarder STP : OM/Corse, PIC. La macro sauvegarde 16 valeurs, il manque ces 2.
- Le fichier modèle prends justement la valeur OM/Corse, c'est possible de le nommer : SUIVI_ETAORG_20200414_V2_OM/Corse
- Si tu peux enlever la première manip de sélectionner la colonne A et d'exécuter directement la macro, ça sera top.
Merci beaucoup,
Le nom OM/Corse n'est pas autorisé comme nom de fichier. Il ne faut pas /
Donc le nom SUIVI_ETAORG_20200414_V2_OM/Corse
n'est pas possible car cela voudrait dire que SUIVI_ETAORG_20200414_V2_OM
est un sous-dossier
Tu changes le nom OM/Corse et tout ira bien.
L'erreur est dûe à cela.
Dans la macro, tu remplaces ceci
'colonne = Application.InputBox("Entrez la colonne servant de critère de dispatching : ", "Saisie en texte (i.e : A B ...)", Type:=2)
'critere = ActiveSheet.Columns(colonne).Column
UserForm1.Show
If critere = 0 Then Exit Sub
par
critere = 1
Je te rappelle que sauf erreur de ma part je n'ai pas de macro dans ton fichier. Mais je n'ai pas non plus téléchargé le dernier.
Si tu es si à la bourre que cela, prend toi un peu plus à l'avance, ne demande pas des aménagements que l'on peut faire ensuite, poste tout de suite un fichier (léger !). On est là pour t'aider mais c'est réciproque !