XL 2016 Fragmenter un classeur en plusieurs classeurs

[anthony84]

Bonjour,
je souhaiterais fragmenter le fichier excel en plusieurs fichiers excel.
Les fichiers seront enregistrés comme dans la colonne A et suivi de "commandes".
Dans ces fichiers mettre des onglets nommés comme dans la colonne F, soit un onglet avec l'un ou l'autre ou deux onglets s'il y a les deux.
Et mettre les lignes concernées sans la colonne F dans chaque fichier.
Est-ce faisable ?
Merci,

 

[Staple1600]

Bonsoir le fil, anthony84

anthony84
Oui. Non seulement c'est possible mais le sujet a été traité moult fois sur le forum
Voir par exemple les dix exemples en bas de page dans les discussions similaires.
Voir aussi avec le moteur de recherche du forum

 

[job75]

Bonsoir anthony84, bienvenue sur XLD, salut JM,

Voyez le fichier .xlsm joint et la macro affectée au bouton :

Sub Fragmenter()
Dim chemin$, a, d As Object, i&, w As Worksheet
chemin = ThisWorkbook.Path & "\" 'à adapter
With [A1].CurrentRegion.Resize(, 6)
    a = .Value 'matrice, plus rapide
    Set d = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a)
        d(UCase(a(i, 6))) = ""
    Next i
    If d.Count = 0 Then Exit Sub
    a = d.keys
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False 'si les fichiers ont déjà été créés
    Set w = Workbooks.Add(xlWBATWorksheet).Sheets(1) 'nouveau document
    For i = 0 To UBound(a)
        .AutoFilter 6, a(i) 'filtre automatique
        .Resize(, 4).Copy w.Cells(1)
        w.Columns.AutoFit 'ajustement largeur
        w.Name = a(i)
        w.Parent.SaveAs chemin & a(i), 51 'fichier .xlsx
        w.Cells.Delete 'RAZ
    Next i
    w.Parent.Close False
    .Parent.AutoFilterMode = False 'retire le filtre
End With
End Sub

Bonne nuit.

 

[job75]

Bonjour le forum,

Relisant le post #1 je pense que le problème est nettement plus compliqué, il faut faire 2 filtrages, un pour créer les fichiers, un autre pour créer les feuilles.

Voyez ce fichier (2) et la nouvelle macro :

Sub Fragmenter()
Dim chemin$, a, d As Object, dd As Object, i&, x$, y$, z$, b, wb As Workbook, s, j&, w As Worksheet
chemin = ThisWorkbook.Path & "\Fragmentation\" 'dossier à adapter
If Dir(chemin, vbDirectory) = "" Then MkDir chemin 'création du dossier
With [A1].CurrentRegion.Resize(, 6)
    a = .Value 'matrice, plus rapide
    Set d = CreateObject("Scripting.Dictionary")
    Set dd = CreateObject("Scripting.Dictionary")
    For i = 2 To UBound(a)
        x = UCase(a(i, 1)): y = UCase(a(i, 6)): z = x & Chr(1) & y
        If x <> "" And y <> "" Then
            If Not dd.exists(z) Then
                dd(z) = ""
                d(x) = d(x) & Chr(1) & y
            End If
        End If
    Next i
    If d.Count = 0 Then Exit Sub
    a = d.keys: b = d.items
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False 'si les fichiers ont déjà été créés
    For i = 0 To UBound(a)
        Set wb = Workbooks.Add(xlWBATWorksheet) 'nouveau document
        .AutoFilter 1, a(i) 'filtre automatique
        .Copy wb.Sheets(1).Cells(1) 'copier-coller sur 1ère feuille
        s = Split(b(i), Chr(1))
        For j = 1 To UBound(s)
            Set w = wb.Sheets.Add(After:=wb.Sheets(wb.Sheets.Count)) 'nouvelle feuille
            w.Name = s(j)
            With wb.Sheets(1).UsedRange
                .AutoFilter 6, s(j) 'filtre automatique
                .Resize(, 4).Copy w.Cells(1) 'copier-coller sur dernière feuille
            End With
            w.Columns.AutoFit 'ajustement largeurs
        Next j
        wb.Sheets(1).Delete
        wb.Sheets(1).Activate
        wb.SaveAs chemin & a(i), 51 'fichier .xlsx
        wb.Close False
    Next i
    .Parent.AutoFilterMode = False 'retire le filtre
End With
End Sub

Les fichiers créés sont dans le dossier "Fragmentation".

Bonne journée.

 

[anthony84]

Bonjour,
merci Job 75, c'est tout à fait ce que je veux.
Je n'ai pas tout compris, je vais voir demain si je peux modifier la macro à mon fichier du travail.
Merci beaucoup.

 

[Staple1600]

Bonjour le fil, anthony84, job75

anthony84
La(le) suggestion/conseil du message#2 reste valable (au moins pour d'autres questions)
En tout cas, même si cela n'est pas une solution en soi, pour autant cela n'empeche pas le demandeur d'également me saluer, non ?
🙄

 

[anthony84]

Merci à tous

 

[Staple1600]

Re

anthony84
Suceptible?
Un Bonjour Staple aurait suffit 😉

Et juste pour te montrer que mon conseil n'était pas vain
Deux exemples de discussions issus des archives du forum (trouvé avec le moteur de recherche du forum)

Créer une macro qui découpe un fichier Excel en plusieurs fichiers différents

Bonjour, C'est ma 1ère demande dans ce forum :) Pourriez-vous m'aider sur un problème svp? Je souhaite créer une macro qui permet de découper un fichier Excel en plusieurs fichiers selon un critère défini. Le critère de génération de chaque nouveau fichier est le changement de contenu...

www.excel-downloads.com

Repartir des données ds plusieurs classeurs (bis)

Bonjour à Tous, Voici ma demande: J'ai un onglet ''Portefeuille" qui contient un tableau avec quelques données, la macro actuelle (et au passage je remercie Robert) permet de répartir les données de ce tableau dans 4 onglets... le critère de répartition est très simple c'est la valeur de...

www.excel-downloads.com

 

[job75]

JM, sauf erreur je n'ai jamais vu sur XLD un double filtrage (avec 2 Dictionary) pour créer des fichiers et leurs feuilles.

Même si des solutions voisines existent il faudra les adapter et c'est là que le répondeur doit fournir de l'aide car ce n'est pas de la tarte.

 

[Staple1600]

Re

job75
Je m'adressais seulement à anthony84 et simplement sur le fait de ne pas saluer tous les intervenants d'un fil.
(Et ce parce que c'est un nouveau membre, et que de nombreux nouveaux membres ont cette manie de ne saluer ou remercier que le dernier intervenant du fil)

 

[job75]

Moi je m'adresse à toi au sujet de ton "conseil" qui en général n'est pas inutile mais est totalement insuffisant ici.

 

[Staple1600]

Re

Et donc?
J'ai donné un conseil que tu juges insuffisant.
Tu as donné une solution.
La seule chose qui me chatouille c'est ce que j'évoque au message#6
(et qui encore une fois s'adressait au seul demandeur)

 

[job75]

Après 14 ans sur XLD tu devrais savoir qu'il est très courant que le demandeur ne réponde pas aux messages inutiles ou qui l'agacent.

Je trouve ça normal, et c'est mon cas par exemple.

 

[Staple1600]

Re

job75

Au sujet de ton "conseil" qui en général n'est pas inutile

ne réponde pas aux messages inutiles ou qui l'agacent.

Faudrait savoir...

PS: Pour les objurgations, le MP eut été plus avisé...

 

[job75]

Bonjour anthony84, JM, le forum,

Dans ce fichier (3) j'ai ajouté 2 compléments :

- en début de macro, par sécurité, fermeture de tous les fichiers ouverts (autres que ThisWorkbook)

- en fin de macro suppression des fichiers non listés dans le dossier "Fragmentation".

Bonne journée.