Découper un fichier xls en plusieurs fichiers avec Feuilles

Bonjour,

Je souhaite découper un fichier excel en plusieurs en filtrant sur une colonne A et contenant des feuilles. Par exemple, dans le fichier joint "FichierDepart.xlsx" je voudrais obtenir des fichiers par valeurs qui se trouve dans la colonne A et de reproduire la même traitement pour chaque feuilles, avec comme nom de fichier la valeur de la cellule contenant bien sur toutes les colonnes du fichier de départ.

Exemple:

FichierDepart.xlsx:

Feuil1

Colonne A | Colonne B| Colonne C....

toto 23 France

toto 56 Italie

titi 45 Espagne

Feuil2

Colonne A | Colonne B| Colonne C....

toto 74 Congo

titi 28 Canada

Résultat après traitement:

Fichier nom = Toto.xlsx

Feuil1

Colonne A | Colonne B| Colonne C....

toto 23 France

toto 56 Italie

Feuil2

Colonne A | Colonne B| Colonne C....

toto 74 Congo

////////////////////////////////////////////////////////////////////////////////

Fichier nom = Titi.xlsx

Feuil1

Colonne A | Colonne B| Colonne C....

titi 45 Espagne

Feuil2

Colonne A | Colonne B| Colonne C....

titi 28 Canada

En vous remerciant par avance pour votre aide.

Bonjour,

Voilà quelque chose à tester :

Sub GénérerClasseurs()
    Dim d As Object, wbk As Workbook, k, itm, kitm, kk, et, f%, n%, i%, ch$, rw$
    Set d = CreateObject("Scripting.Dictionary")
    With ThisWorkbook
        For f = 1 To .Worksheets.Count
            With .Worksheets(f)
                n = .Cells(.Rows.Count, 1).End(xlUp).Row
                For i = 2 To n
                    kitm = .Cells(i, 1)
                    k = "wb_" & kitm: itm = "ws" & f
                    If d.exists(k) Then
                        If InStr(d(k), itm) = 0 Then d(k) = d(k) & ";" & itm
                    Else
                        d(k) = ";" & itm
                    End If
                    k = itm & "_" & kitm: kitm = kitm & "_" & itm: itm = "rw" & i
                    If d.exists(k) Then
                        If InStr(d(k), itm) = 0 Then d(k) = d(k) & ";" & itm
                    Else
                        d(k) = ";" & itm
                    End If
                    kitm = kitm & itm: itm = .Cells(i, 1).Resize(, 3).Value
                    d(kitm) = itm
                Next i
            End With
        Next f
        et = .Worksheets(1).Range("A1:C1").Value
        ch = .Path & "\"
    End With
    Application.ScreenUpdating = False
    For Each k In d.keys
        If k Like "wb_*" Then
            kitm = Split(k, "_")(1)
            Set wbk = Workbooks.Add(xlWBATWorksheet)
            wbk.SaveAs ch & kitm & ".xlsx"
            itm = Split(d(k), ";")
            With wbk
                If UBound(itm) > 1 Then
                    For f = 2 To UBound(itm)
                        .Worksheets.Add after:=.Worksheets(f - 1)
                    Next f
                End If
                For f = 1 To UBound(itm)
                    kk = Split(d(itm(f) & "_" & kitm), ";"): n = 1
                    With .Worksheets(f)
                        .Cells(n, 1).Resize(, 3).Value = et
                        For i = 1 To UBound(kk)
                            n = n + 1
                            rw = kitm & "_" & itm(f) & kk(i)
                            .Cells(n, 1).Resize(, 3).Value = d(rw)
                        Next i
                    End With
                Next f
                .Close True
            End With
        End If
        Set wbk = Nothing
    Next k
End Sub

Je n'ai pas mis de bouton, à toi de t'organiser selon tes préférences... Pour tester, tu peux simplement lancer la macro à partir de la boîte de dialogue macro.

Préalablement, il convient d'enregistrer le classeur départ dans un dossier. Les classeurs créés seront enregistrés dans le même dossier et tu les y retrouveras après exécution de la macro.

Cordialement.

Bonsoir MFerand et merci de prendre du temps pour mon problème.

tu as répondu exactement à ma demande.

merci encore pour ton aide

Bonjour à tous !

Je relance ce "vieux" sujet, mais j'ai besoin d'un complément d'information !

Alors voilà, j'ai utilisé le code indiqué ci-dessus pour mon propre fichier, et c'est parfait, ça fonctionne à merveille !

Je m'interroge juste sur le nom que porte les fichiers lors de leur création après l'enregistrement automatique.

Actuellement, ils portent le nom de la colonne A (3 cellules différentes en colonne A = 3 fichiers disctincs)

J'aimerais donc pouvoir modifier ça, et soit faire en sorte d'utiliser cette formule pour d'autre colonne, et aussi pouvoir combiner les noms des fichiers par les cellules des colonnes A & B....

Merci de votre aide!

Cdlt,

Bonjour,

Ce code est adapté si tu as exactement la même configuration de départ et si tu veux faire la même chose.

La situation étant très personnalisée, le code l'est donc également !

On part d'un classeur comportant des mentions sur 3 colonnes (le nb de colonnes importe peu, ça s'adapte aisément... ) et sur plusieurs feuilles. La première colonne porte des noms qui se répètent, et le but est d'éclater le classeur initial en classeur par nom en conservant les données de chaque nom et leur répartition en feuilles.

Si tu opères dans une structure exactement similaire, cette procédure peut en effet être adaptable...

Comme tu peux le voir, elle procède en deux temps : recueil de toutes les données, puis constitution des nouveaux classeurs à partir des données recueillies.

La partie délicate réside dans le recueil des données, pour lequel on utilise l'outil Dictionary.

On n'utilise formellement qu'un seul dictionnaire, mais on en constitue 3 distincts qui pourront cohabiter dans le même ensemble :

- un dico nom d'abord : un élément de dictionnaire dont la clé est le nom par futur classeur à constituer, le contenu de chaque élément dico est une chaîne listant les feuilles du futur classeur ;

- un dico nom-feuille ensuite : soit un élément dico dont la clé est formée par concaténation du nom avec une indication de feuille, il y aura autant d'éléments de l'espèce que le nombre total de feuilles dans l'ensemble des classeurs à constituer, le contenu de chaque élément est une chaîne listant les lignes qui devront être insérées dans la feuille identifiée ;

- un dico nom-feuille-ligne enfin : soit élément dico dont la clé concatène le nom avec une indication de feuille et une indication de ligne, il y aura autant d'éléments de ce type que de lignes de données à reporter dans l'ensemble des classeurs, le contenu de chaque élément est constitué par les données, recueillies sous forme de tableaux.

Si tu peux te situer dans un tel processus, des variations de détails peuvent sans doute être introduites à des fins d'adaptations, tant qu'on suit la même trajectoire, organisation similaire des données de départ et objectif identique de réalisation.

Si cela correspond, on peut adapter sans difficulté majeure. Sinon, la procédure n'est pas adaptée, on l'abandonne sans regret et on repart à zéro sur l'analyse du problème pour concevoir une procédure qui soit adaptée !

A toi de répondre à cette question !

Bonjour à tous,

Je suis moi aussi à la recherche d'aide pour mettre en place une macro qui découpe un fichier XLS en plusieurs fichiers.

Je joins mon fichier. Je cherche & découper mon fichier selon plusieurs possibilités : soit une découpe par RRH (colonne A), soit par Manager ( colonne B) soit par société (colonne E). Après le découpage je souhaiterais récupérer plusieurs fichiers qui seraient enregistrés dans le même dossier que le fichier source.

J'ai essayé de bidouiller plusieurs macros mais je n'arrive pas à mes fins.

Je suis preneuse de toute aide

D'avance, un grand merci !

Bonjour Avrilae,

D'une part, il faut choisir ce que tu veux faire...

D'autre part, sans données, il n'y a rien à découper !

Cordialement.

Bonjour,

Merci pour ta réponse rapide.

Alors partons sur un découpage par RRH (colonne A).

Je joins un fichier avec quelques données.

D'avance un grand merci !!!

Bonjour,

Ton cas étant relativement simple, il n'est pas utile de mobiliser le même arsenal que pour le sujet de référence. Ce qui complique un peu est ton en-tête avec cellules fusionnées.

On va donc traiter ton en-tête à part et la reproduire par copier-coller ordinaire qui répercutera sa mise en forme.

Sub GénérerClasseurs()
    Dim aa, rh, ln, RRH(), plgET As Range, chD$, k%, n&, i&, d As Object
    With ActiveSheet
        i = .Range("A" & .Rows.Count).End(xlUp).Row
        If i <= 13 Then Exit Sub
        k = .Cells.SpecialCells(xlCellTypeLastCell).Column
        aa = .Range("A13:A" & i).Resize(, k).Value
        Set plgET = .Range("A8:A12").Resize(, k)
    End With
    chD = ThisWorkbook.Path & "\"
    Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(aa)
        d(aa(i, 1)) = d(aa(i, 1)) & ";" & i
    Next i
    Application.ScreenUpdating = False
    For Each rh In d.keys
        ln = Split(d(rh), ";"): n = UBound(ln)
        ReDim RRH(1 To n)
        For i = 1 To n
            RRH(i) = WorksheetFunction.Index(aa, CInt(ln(i)), 0)
        Next i
        With Workbooks.Add(xlWBATWorksheet)
            With .Worksheets(1)
                plgET.Copy .Range("A1")
                With .Range("A6").Resize(n, k)
                    .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(RRH))
                    .Borders.Weight = xlThin
                End With
            End With
            .SaveAs chD & rh & ".xlsx"
            .Close
        End With
    Next rh
End Sub

La méthode consiste donc à :

1) Sur la feuille, on relève les dimensions de ton tableau en ligne et colonne, on récupère en tableau (aa) la plage de données (à partir ligne 13), on affecte l'en-tête à une variable Range (plgET), et note qu'on conserve la dimension colonne (k) qui ne variera pas pour les classeurs résultant.

On recueille aussi le chemin du classeur dans une variable (chD)

On peut alors continuer sur tableau...

2) On initialise un dictionnaire dont chaque élément sera par un RRH destiné à générer un classeur dédié.

On parcout le tableau de données pour constituer ce dictionnaire : pour chaque élément RRH on concatène les numéros de lignes concernées du tableau, séparés par des points-virgules.

3) On passe à la phase création de classeurs (désactivation de la mise à jour de l'affichage, car là ce qu'on va faire aura des effets visibles...)

Boucle sur chaque élément dico : chaque tour de boucle donnera lieu à création d'un classeur.

Pour chaque élément dico (sa clé : rh constitue le nom du futur classeur) :

• on récupère en tableau (ln) la liste à prélever dans le tableau de données pour le classeur à constituer [ce tableau comporte un élément 0 vide, on parcourra donc les lignes de 1 à n (variable à laquelle on affecte l'indice maximal de ln) pour récupérer les données afférentes ;
• on dimensionne (1 à n) un tableau de résultats (RRH), auquel on va affecter les lignes prélevées dans le tableau de données (aa) ;
• on procède au prélèvement en utilisant la fonction Excel INDEX, qui nous permet de prélever la ligne entière pour l'affecter à un élément du tableau RRH (lequel n'est de ce fait qu'un tableau unidimensionnel, dont chaque élément contient lui-même un tableau, qui est une ligne de données) ;
• on crée un nouveau classeur, muni d'une seule feuille ;
• on reproduit sur cette feuille l'en-tête, par copier-coller ;
• on y affecte ensuite les données à la suite de l'en-tête, affectation directe du tableau RRH à la plage cible dimensionnée à la taille des données (au moyen des variables n et k), qui compte tenu de la nature de ce tableau (tableau unidimensionnel de tableaux) doit s'opérer par une double transposition (utilisant la fonction Excel Transpose).

NB- Si tu constates qu'à l'issue de l'opération l'en-tête du tableau source conserve un pourtour scintillant, tu pourras ajouter à la fin de la macro (avant End Sub) la ligne :

Application.CutCopyMode = False

qui l'éliminera (c'est à ça qu'elle sert... )

Cordialement.

Magnifique !!! Merci beaucoup. J'ai économisé de longues heures de travail !!

J'ai 2 questions additionnelles :

• si je souhaite découper par la colonne B, que dois-je ajouter pour que la macro recopie également la colonne A (et pas uniquement les colonnes B à ... la fin du classeur...)
• Est-il possible d'ajouter le copier coller d'un onglet (qui lui ne sera pas modifié : onglet type mode d'emploi)

Si tu découpes sur B au lieu de A, la seule chose à modifier est :

    For i = 1 To UBound(aa)
        d(aa(i, 1)) = d(aa(i, 1)) & ";" & i
    Next i

en :

    For i = 1 To UBound(aa)
        d(aa(i, 2)) = d(aa(i, 2)) & ";" & i
    Next i

NB- Si je l'avais fait au départ sur B, j'aurais nommé autrement les variables RRH() et rh, mais cela ne les empêchera nullement de fonctionner de la même façon...

Pour insérer une feuille provenant du classeur source dans chaque classeur :

• tu ajoutes une variable dans les déclarations, par exemple : wsME As Worksheet
• tu l'initialises dans la première partie, de cette façon par exemple :

    With ThisWorkbook
        chD = .Path & "\"
        Set wsME = .Worksheets("Memo") 'nom à adapter
    End With

et tu réalisers l'insertion de copie (ce n'est pas précisément un copier-coller ) de la feuille à :

        With Workbooks.Add(xlWBATWorksheet)
            With .Worksheets(1)
                '...
            End With
            wsME.Copy after:=.Worksheets(1) 'ou before:=, au choix
            .SaveAs chD & rh & ".xlsx"
            .Close
        End With

Cordialement.

Merci beaucoup MFerrand !!!! Non seulement tu nous donnes la solution mais aussi tu prends le temps d'expliquer.

Avrilae

Bonjour MFerrand,

Une dernière question (je l'espère ).

Voici le code obtenu (qui fonctionne !!!)

Sub DécoupageManager()
    Dim aa, rh, ln, RRH(), plgET As Range, chD$, k%, n&, i&, d As Object, wsME As Worksheet, wsSAIS As Worksheet
            With ThisWorkbook
        chD = .Path & "\"
        Set wsME = .Worksheets("Mode d'emploi")
        Set wsSAIS = .Worksheets("Saisie")
    End With

    With ActiveSheet
        i = .Range("A" & .Rows.Count).End(xlUp).Row
        If i <= 13 Then Exit Sub
        k = .Cells.SpecialCells(xlCellTypeLastCell).Column
        aa = .Range("A13:A" & i).Resize(, k).Value
        Set plgET = .Range("A1:A12").Resize(, k)
    End With
    chD = ThisWorkbook.Path & "\"
        Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(aa)
        d(aa(i, 2)) = d(aa(i, 2)) & ";" & i
    Next i

    Application.ScreenUpdating = False
    For Each rh In d.keys
        ln = Split(d(rh), ";"): n = UBound(ln)
        ReDim RRH(1 To n)
        For i = 1 To n
            RRH(i) = WorksheetFunction.Index(aa, CInt(ln(i)), 0)
        Next i

        With Workbooks.Add(xlWBATWorksheet)
            With .Worksheets(1)
                plgET.Copy .Range("A1")
                With .Range("A13").Resize(n, k)
                    .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(RRH))
                    .Borders.Weight = xlThin
                End With
            End With
            wsME.Copy before:=.Worksheets(1)
            wsSAIS.Copy after:=.Worksheets(1)
            .SaveAs chD & rh & ".xlsx"
            .Close
        End With
    Next rh

        MsgBox "Découpage du fichier terminé !"
End Sub

Dans mon fichier, j'ai 3 feuilles :

• une feuille "Mode d'emploi" (feuille qui n'a pas à être modifiée)
• une feuille Data avec les données
• et je souhaiterai ajouter une feuille "Saisie" qui reprendrai les données de l'onglet Data (avec de nombreuses RechercheV...). L'idée de cette feuille est d'avoir un tableau un peu allégé versus la feuille source "Data"

J'ai réussi grace à ton aide à ajouter la feuille mode d'emploi. J'ai également inséré une feuille "Saisie" avec des formules liant l'onglet Saisie à l'onglet Data mais les formules du nouveau fichier font référence au fichier initial et non au résultat de la "découpe". Je ne suis pas sure que cela fonctionne en cas d'envoi du fichiers à des tiers.

Ma demande : comment inserer la feuille "Saisie" qui ne reprenne que les données de la feuille Data après découpage

Comment faire en sorte que les onglets conservent tous leur nom initial ?

J'espère être claire dans ma demande. J'ai joint mon fichier retravaillé.

D'avance un grand grand merci

Bonjour,

Il y a deux choses :

D'abord, si tu voulais faire un double découpage, RRH et Manager, chacun lancé par un bouton, la même procédure étant utilisable en faisant varier un paramètre, on ne duplique pas la procédure, c'est reproduire inutile un code identique ! Etant en un seul exemplaire il peut fonctionner pareil tout aussi efficacement...

Tu dotes la procédure d'un argument correspondant au paramètre à faire varier, et chacun des bouton lancera la procédure en lui passant une valeur différente de ce paramètre.

Dans la procédure, tu remplaces la valeur en dur du paramètre par le nom de l'argument, qui joue le même rôle qu'une variable, et le tour est joué !

Pour ta 2e question, généralement on expurge les feuilles exportées de formules pour éviter de créer des liens entre classeurs lors de cette opération. Mais je ne vois pas bien l'utilité de cette feuille... ?

Cordialement.

Bonjour,

L'interet de cette seconde feuille est d'avoir une synthèse avec les quelques éléments importants et ainsi éviter d'avoir un tableau avec 30 colonnes . L'idée est d'avoir une sorte de formulaire de saisie.

Est-ce possible ?

Merci

Bonjour,

Je ne vois pas très bien en quoi ça pourrait jouer le rôle de formulaire, surtout étant constituée à partir de formules...

Tu la constitues sans formule au départ, telle que tu la veux à l'arrivée, et tu peux l'exporter sans problème, mais je garde le sentiment que ça fait quelque peu doublon.

Cordialement.

Bonjour,

J'ai retravaillé mon fichier.

Pour mémoire il s'agit d'un fichier que j'envoie à des services Ressources Humaines pour qu'ils travaillent sur les augmentation de salaire. L'idée est qu'ils puissent redécouper le fichier (bouton accessible depuis l'onglet "Découpage").

Le découpage fonctionne très bien (j'ai bidouillé, ça ne doit pas être très académique mais cela fonctionne).

En revanche je suis confrontée à 2 soucis :

- est_il possible de conserver les formules qui apparaissent dans le corps de la feuille Données (formules sans lien avec d'autres feuilles) : c'est vraiment ma priorité puisque je souhaite que ce fichier puisse etre envoyé puis redécoupé par les destinataires tout en conservant les formules (j'aimerai que lorsqu'ils saisissent une augmentation, le nouveau salaire soit calculé).

Pour le moment seules les formules sur les 15 premières lignes sont conservées, mais les données découpées perdent leurs formules.

- est_il possible de conserver le format des nombre (nombre de décimales, séparateur de milliers, format, etc...), la largeur des colonnes, etc... ?

Voici le code que je souhaiterai modifier + fichier joint

Sub DécoupageRRH()
    Dim aa, rh, ln, RRH(), plgET As Range, chD$, k%, n&, i&, d As Object, wsME As Worksheet, wsDATA As Worksheet, wsDECOUP As Worksheet
            With ThisWorkbook
        chD = .Path & "\"
        Set wsME = .Worksheets("Mode d'emploi")
        Set wsDATA = .Worksheets("Données")
        Set wsDECOUP = .Worksheets("Découpage fichiers")
    End With

    With wsDATA
        i = .Range("A" & .Rows.Count).End(xlUp).Row
        If i <= 15 Then Exit Sub
        k = .Cells.SpecialCells(xlCellTypeLastCell).Column
        aa = .Range("A15:A" & i).Resize(, k).Value
        Set plgET = .Range("A1:A14").Resize(, k)
    End With
    chD = ThisWorkbook.Path & "\"
        Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(aa)
        d(aa(i, 1)) = d(aa(i, 1)) & ";" & i
    Next i

    Application.ScreenUpdating = False
    For Each rh In d.keys
        ln = Split(d(rh), ";"): n = UBound(ln)
        ReDim RRH(1 To n)
        For i = 1 To n
            RRH(i) = WorksheetFunction.Index(aa, CInt(ln(i)), 0)
        Next i

        With Workbooks.Add(xlWBATWorksheet)
             .Worksheets(1).Name = ("Données")
            With .Worksheets(1)
                            plgET.Copy .Range("A1")
                With .Range("A15").Resize(n, k)
                    .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(RRH))
                    .Borders.Weight = xlThin
                End With
            End With
            wsME.Copy before:=.Worksheets(1)
              wsDECOUP.Copy before:=.Worksheets(1)
            .SaveAs chD & rh & ".xlsx"
            .Close
        End With
    Next rh

        MsgBox "Découpage du fichier terminé !"
End Sub

D'avance merci pour vos réponses.

Bonjour,

J'ai avancé mais reste bloquée sur un point.

J'ai réussi à modifier le code afin de conserver toutes mes formules, ouf...

En revanche je n'arrive pas à faire en sorte que mes formats de nombre restent identiques. En gros j'aurais aimé utiliser la fonction "Reproduire la mise en forme" de ma feuille source vers le classeur nouvellement créé. Mais je ne vois pas du tout comment l'intégrer dans le code.

Avez-vous une solution ?

Ci-après le code & le fichier

Sub DécoupageRRH()
    Dim aa, rh, ln, RRH(), plgET As Range, chD$, k%, n&, i&, d As Object, wsME As Worksheet, wsDATA As Worksheet, wsDECOUP As Worksheet
            With ThisWorkbook
        chD = .Path & "\"
        Set wsME = .Worksheets("Mode d'emploi")
        Set wsDATA = .Worksheets("Données")
        Set wsDECOUP = .Worksheets("Découpage fichiers")
    End With

    With wsDATA
        i = .Range("A" & .Rows.Count).End(xlUp).Row
        If i <= 16 Then Exit Sub
        k = .Cells.SpecialCells(xlCellTypeLastCell).Column
        aa = .Range("A16:A" & i).Resize(, k).FormulaR1C1
        Set plgET = .Range("A1:A15").Resize(, k)
    End With
    chD = ThisWorkbook.Path & "\"
        Set d = CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(aa)
        d(aa(i, 1)) = d(aa(i, 1)) & ";" & i
    Next i

    Application.ScreenUpdating = False
    For Each rh In d.keys
        ln = Split(d(rh), ";"): n = UBound(ln)
        ReDim RRH(1 To n)
        For i = 1 To n
            RRH(i) = WorksheetFunction.Index(aa, CInt(ln(i)), 0)
        Next i

        With Workbooks.Add(xlWBATWorksheet)
             .Worksheets(1).Name = ("Données")
            With .Worksheets(1)
                            plgET.Copy .Range("A1")
                With .Range("A16").Resize(n, k)

                    .Value = WorksheetFunction.Transpose(WorksheetFunction.Transpose(RRH))

                    .Borders.Weight = xlThin

                End With
            End With
            wsME.Copy before:=.Worksheets(1)
              wsDECOUP.Copy before:=.Worksheets(1)
            .SaveAs chD & rh & ".xlsx"
            .Close
        End With
    Next rh

        MsgBox "Découpage du fichier terminé !"
End Sub

Merci pour votre aide.

Avrilae