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,

capture

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,

capture

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

Ree,

J'ai essayé, mais ça me donne toujours des messages d'erreur et ça ouvre un autre fichier Excel "Model". Pouvez-vous garder le format du fichier Suivi_...(lignes/colonnes) ?

Je vous renvoie le lien de la version :

capture capture1

J'ai réessayé et ça l'air de marcher. Pouvez-vous appliquer cela à ma version ? Vous avez rajouté une couleur et l'emplacement.., je n'en ai pas besoin, merci bcp

Il me donne aussi et toujours ce msg d'erreur. il faut que je clique sur fin.

capture111

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.

  • 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)
3/ Ne pas créer un autre fichier excel ouvert "Model", il ne sert à rien à mon avis

Merci d'avance,

capture2 capture1

là SVP, il me crée un un autre fichier model, j'en ai pas besoin. Et il me donne aussi un message d'erreur, que je puisse faire ?

capture2
  • 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)
3/ Ne pas créer un autre fichier excel ouvert "Model", il ne sert à rien à mon avis

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
ou de le sauvegarder avec les autres valeurs sans le faire ouvrir.

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

Rechercher des sujets similaires à "creer macro scinder fichier fichiers"