XL 2016 Fragmenter un classeur en plusieurs classeurs

anthony84

XLDnaute Nouveau
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,
 

Pièces jointes

  • Commande.xlsx
    9.4 KB · Affichages: 3

Staple1600

XLDnaute Barbatruc
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

XLDnaute Barbatruc
Bonsoir anthony84, bienvenue sur XLD, salut JM,

Voyez le fichier .xlsm joint et la macro affectée au bouton :
VB:
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.
 

Pièces jointes

  • Commande(1).xlsm
    19.6 KB · Affichages: 6

job75

XLDnaute Barbatruc
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 :
VB:
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.
 

Pièces jointes

  • Commande(2).xlsm
    21.8 KB · Affichages: 8

Staple1600

XLDnaute Barbatruc
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 ?
:rolleyes:
 

Staple1600

XLDnaute Barbatruc
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)

 

job75

XLDnaute Barbatruc
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

XLDnaute Barbatruc
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

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

Pièces jointes

  • Commande(3).xlsm
    21.6 KB · Affichages: 8
Haut Bas