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,
 

Fichiers joints

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.
 

Fichiers joints

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.
 

Fichiers joints

anthony84

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

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)
 

Staple1600

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

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

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.
 

Fichiers joints

Créez un compte ou connectez vous pour répondre

Vous devez être membre afin de pouvoir répondre ici

Créer un compte

Créez un compte Excel Downloads. C'est simple!

Connexion

Vous avez déjà un compte? Connectez vous ici.

Haut Bas