XL 2016 VBA decomposer fichier en plusieurs fichiers avec critères et sans liaison

ZZ59264 · 3 Décembre 2021

Bonjour à tous,

Je viens demandé de l'aide pour un projet assez conséquent, je joins donc un fichier à ma demande avec les explications,

Je suis prêt à écouter toute proposition (modifications,idées ...) pour aboutir au projet,

Merci d'avance pour votre aide,

job75 · 3 Décembre 2021

Bonsoir ZZ59264,

Plusieurs questions :

- comment pouvons-nous tester notre travail quand notre ordi n'a pas de lecteur P ?

- les dossiers du chemin P:\P-E\C G\B CR\Z\2020 ont-ils été déjà été créés une fois pour toutes ?

- dans les fichiers il n'y aura vraiment qu'une ou 2 lignes, celles des onglets G H I J etc... ? C'est étrange...

Bonne nuit et à demain.

job75 · 4 Décembre 2021

Bonjour ZZ59264, le forum,

Téléchargez le fichier joint et ouvrez-le.

1) Commencez par vérifier que tous les boutons ont des noms différents.

Si ce n'est pas le cas renommez-les, par exemple CLASSEUR 1 CLASSEUR 2 CLASSEUR 3...

2) Ensuite touches Alt+F11 => menu Insertion et collez cette macro dans un module VBA :

VB:

Sub Creer_Fichiers_Classes()
Dim F As Worksheet, classe$, P As Range, i As Variant, s, chemin$, c As Range, Q As Range
'---préparation---
Set F = Feuil1 'CodeName
classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents
Set P = F.ListObjects(1).Range 'tableau structuré
P.Sort P(1, 3), xlAscending, Header:=xlYes 'tri sur les classes
i = Application.Match(classe, P.Columns(3), 0) 'EQUIV
If IsError(i) Then MsgBox classe & " non trouvée !", 48: Exit Sub
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'---création des dossiers s'ils n'existent pas---
s = Split(P(1, 4), "\")
chemin = s(0) & "\" 'lecteur
For i = 1 To UBound(s)
    chemin = chemin & s(i) & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Next i
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier a déjà été créé
With Workbooks.Add(xlWBATWorksheet).Sheets(1) 'document auxiliaire
    For Each c In P.Columns(1).Cells
        .Cells.Delete 'RAZ
        Set Q = ThisWorkbook.Sheets(CStr(c)).UsedRange 'plage copiée
        .Range(Q.Address) = Q.Value 'copie uniquement les valeurs
        .Columns.AutoFit 'ajuste les largeurs
        .SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
    Next c
    .Parent.Close False 'ferme le document auxiliaire
End With
End Sub

3) Affectez la macro à chacun des boutons.

4) Cliquez sur le bouton que vous voulez.

Bien sûr si le lecteur n'existe pas il y aura un bug.

A+

ZZ59264 · 4 Décembre 2021

Bonjour Job75,

Merci beaucoup pour votre retour, après un test sur la classe 3 en affectant la macro au bouton classe 3 et le fichier se créer bien avec le bon nom

Le problème qui subsiste c'est que dans ce fichier créer, il y a une Feuil 1, or je souhaiterais l'import de l'onglet G et H (pour la classe 3) du fichier source en conservant également le nom de ces onglets sur le nouveau fichier, et en faisant un collage format et valeur tout en supprimant les liaisons,

Merci d'avance pour votre aide,

Cordialement,

job75 · 4 Décembre 2021

ZZ59264 à dit:
Le problème qui subsiste c'est que dans ce fichier créer, il y a une Feuil 1, or je souhaiterais l'import de l'onglet G et H (pour la classe 3) du fichier source en conservant également le nom de ces onglets sur le nouveau fichier, et en faisant un collage format et valeur tout en supprimant les liaisons,

Il suffit de renommer la feuille et d'ajouter un Collage spécial-Formats, fichier (2) :

VB:

With Workbooks.Add(xlWBATWorksheet).Sheets(1) 'document auxiliaire
    For Each c In P.Columns(1).Cells
        .Name = c 'renomme la feuille
        .Cells.Delete 'RAZ
        Set w = ThisWorkbook.Sheets(CStr(c))
        w.Cells.Copy 'copie toutes les cellules
        .Cells(1).PasteSpecial xlPasteFormats 'colle les formats
        .Cells(1).Select
        Application.CutCopyMode = 0
        Set Q = w.UsedRange 'plage copiée
        .Range(Q.Address) = Q.Value 'copie les valeurs
        .SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
    Next c
    .Parent.Close False 'ferme le document auxiliaire
End With

ZZ59264 · 4 Décembre 2021

Bonjour Job75,

tu es vraiment bon sur VBA

Alors j'ai testé et il subsiste un problème : le fichier créer pour la classe 3 doit avoir deux onglets, le G et le H or il me met que le H,

Pour la classe 4, par exemple le fichier DR-FNP-Z-2020 a un seul onglet (J) mais le fichier DR-CYCLE PERSO-Z-2020 a deux onglets (L et M)... et plus largement car il s'agit d'un fichier test, chaque fichier créer reprends les onglets qui lui correspondent ... je ne sais pas si je me fais bien comprendre désolé ! (Onglet en tete fichier origine, colonne AJ sont les onglets et colonne AK le fichier)

Merci encore pour ton aide, et surtout pour les explications indiquées sur le code qui me permettront de comprendre par la suite le développement du traitement,

Cordialement,

job75 · 4 Décembre 2021

ZZ59264 à dit:
Alors j'ai testé et il subsiste un problème : le fichier créer pour la classe 3 doit avoir deux onglets, le G et le H or il me met que le H,

Ah oui bien sûr, c'est nettement plus compliqué, voyez ce fichier (3) et le nouveau code :

VB:

Sub Creer_Fichiers_Classes()
Dim F As Worksheet, classe$, P As Range, i As Variant, s, chemin$, c As Range, w As Worksheet, Q As Range
'---préparation---
Set F = Feuil1 'CodeName
classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents
Set P = F.ListObjects(1).Range 'tableau structuré
P.Sort P(1, 3), xlAscending, P(1, 2), , xlAscending, P(1), xlAscending, Header:=xlYes 'tri sur les classes, les noms de fichiers et les onglets
i = Application.Match(classe, P.Columns(3), 0) 'EQUIV
If IsError(i) Then MsgBox classe & " non trouvée !", 48: Exit Sub
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'---création des dossiers s'ils n'existent pas---
s = Split(P(1, 4), "\")
chemin = s(0) & "\" 'lecteur
For i = 1 To UBound(s)
    chemin = chemin & s(i) & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Next i
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For Each c In P.Columns(1).Cells
    If c(1, 2) <> c(0, 2) Then 'compare avec le nom de fichier au-dessus
        Set F = Workbooks.Add(xlWBATWorksheet).Sheets(1) 'document auxiliaire avec une feuille
    Else
        Set F = Sheets.Add(After:=Sheets(Sheets.Count)) 'ajoute une feuille au document auxiliaire
    End If
    F.Name = c 'renomme la feuille
    Set w = ThisWorkbook.Sheets(CStr(c))
    w.Cells.Copy 'copie toutes les cellules
    F.Cells(1).PasteSpecial xlPasteFormats 'colle les formats
    F.Cells(1).Select
    Application.CutCopyMode = 0
    Set Q = w.UsedRange 'plage copiée
    F.Range(Q.Address) = Q.Value 'copie les valeurs
    If c(1, 2) <> c(2, 2) Then 'compare avec le nom de fichier au-dessous
        Sheets(1).Select '1ère feuille
        ActiveWorkbook.SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
        ActiveWorkbook.Close False 'ferme le document auxiliaire
    End If
Next c
End Sub

ZZ59264 · 4 Décembre 2021

Bonsoir,

En testant ça marche nickel, c’est juste incroyable

Alors je pousse encore les choses mais la c'est du plus , serait il possible que pour chaque onglet importer sa mise en page soit également importer, comme cela je garderai la mise en page lors de l'impression,

Bon la j'avoue je chipote lol, c'est déjà énorme ce que vous m'avez fait, et je vous remercie beaucoup,

J'ai eu peu de temps mais je vais m'atteler à bien comprendre votre code,

Bonne soirée à vous,

Cordialement,

job75 · 4 Décembre 2021

Copier la mise en page certainement pas.

Mais si elle est la même pour toutes les feuilles on peut la construire.

Bonne nuit.

ZZ59264 · 5 Décembre 2021

job75 à dit:
Copier la mise en page certainement pas.

Mais si elle est la même pour toutes les feuilles on peut la construire.

Bonne nuit.

Bonjour, une suggestion dans ce cas mais qui n'est pas à ma portée, d’ailleurs peut être que la macro que vous avez proposé le fasse déjà !,

Afin de conserver la mise en page, est ce possible que dans le déroulement de la macro, celle ci fasse une création de copie des onglets sur le fichier source, un collage valeur pour ensuite le déplacer sur le nouveau fichier créer,

Je pense que la mise en page serait conserver dans ce cas,

ou si c'est trop compliqué, la mise en page souhaité serait de définir la mise en page sur une seule page,

J’ai une autre question peut on conserver la zone d'impression ?,

Merci d'avance pour votre retour,

Bon dimanche

job75 · 5 Décembre 2021

Bonjour ZZ59264,

Vous avez raison, créer des copies des onglets est la bonne solution, elle conserve la mise en page.

Voyez ce fichier (4), la mise en page de la feuille G et la macro :

VB:

Sub Creer_Fichiers_Classes()
Dim F As Worksheet, classe$, P As Range, i As Variant, s, chemin$, c As Range, w As Worksheet, Q As Range, nom As Name
'---préparation---
Set F = Feuil1 'CodeName
classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents
Set P = F.ListObjects(1).Range 'tableau structuré
P.Sort P(1, 3), xlAscending, P(1, 2), , xlAscending, P(1), xlAscending, Header:=xlYes 'tri sur les classes, les noms de fichiers et les onglets
i = Application.Match(classe, P.Columns(3), 0) 'EQUIV
If IsError(i) Then MsgBox classe & " non trouvée !", 48: Exit Sub
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'---création des dossiers s'ils n'existent pas---
s = Split(P(1, 4), "\")
chemin = s(0) & "\" 'lecteur
For i = 1 To UBound(s)
    chemin = chemin & s(i) & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Next i
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For Each c In P.Columns(1).Cells
    Set w = ThisWorkbook.Sheets(CStr(c))
    w.Visible = xlSheetVisible 'si la feuille est masquée
    If c(1, 2) <> c(0, 2) Then 'compare avec le nom de fichier au-dessus
        w.Copy 'crée un nouveau document
    Else
        w.Copy After:=ActiveSheet 'ajoute la feuille copiée
    End If
    Set Q = w.UsedRange 'plage copiée
    Range(Q.Address) = Q.Value 'copie les valeurs
    If c(1, 2) <> c(2, 2) Then 'compare avec le nom de fichier au-dessous
        For Each nom In ActiveWorkbook.Names
            If Not nom.Name Like "*!Print_Area" Then nom.Delete 'supprime tous les noms définis sauf les zones d'impression
        Next nom
        Sheets(1).Select '1ère feuille
        ActiveWorkbook.SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
        ActiveWorkbook.Close False 'ferme le document
    End If
Next c
End Sub

Dans le document créé tous les noms définis sont supprimés sauf les zones d'impression.

A+

ZZ59264 · 5 Décembre 2021

job75 à dit:

Bonjour ZZ59264,

Vous avez raison, créer des copies des onglets est la bonne solution, elle conserve la mise en page.

Voyez ce fichier (4), la mise en page de la feuille G et la macro :

VB:

Sub Creer_Fichiers_Classes()
Dim F As Worksheet, classe$, P As Range, i As Variant, s, chemin$, c As Range, w As Worksheet, Q As Range, nom As Name
'---préparation---
Set F = Feuil1 'CodeName
classe = F.DrawingObjects(Application.Caller).Text 'les boutons doivent avoir des noms différents
Set P = F.ListObjects(1).Range 'tableau structuré
P.Sort P(1, 3), xlAscending, P(1, 2), , xlAscending, P(1), xlAscending, Header:=xlYes 'tri sur les classes, les noms de fichiers et les onglets
i = Application.Match(classe, P.Columns(3), 0) 'EQUIV
If IsError(i) Then MsgBox classe & " non trouvée !", 48: Exit Sub
Set P = P(i, 1).Resize(Application.CountIf(P.Columns(3), classe), P.Columns.Count)
If Application.CountIf(P.Columns(5), "OK") <> P.Rows.Count Then MsgBox "Il faut que tous les onglets de " & classe & " soient validés par OK...": Exit Sub
'---création des dossiers s'ils n'existent pas---
s = Split(P(1, 4), "\")
chemin = s(0) & "\" 'lecteur
For i = 1 To UBound(s)
    chemin = chemin & s(i) & "\"
    If Dir(chemin, vbDirectory) = "" Then MkDir chemin
Next i
'---création des fichiers---
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'si un fichier a déjà été créé
For Each c In P.Columns(1).Cells
    Set w = ThisWorkbook.Sheets(CStr(c))
    w.Visible = xlSheetVisible 'si la feuille est masquée
    If c(1, 2) <> c(0, 2) Then 'compare avec le nom de fichier au-dessus
        w.Copy 'crée un nouveau document
    Else
        w.Copy After:=ActiveSheet 'ajoute la feuille copiée
    End If
    Set Q = w.UsedRange 'plage copiée
    Range(Q.Address) = Q.Value 'copie les valeurs
    If c(1, 2) <> c(2, 2) Then 'compare avec le nom de fichier au-dessous
        For Each nom In ActiveWorkbook.Names
            If Not nom.Name Like "*!Print_Area" Then nom.Delete 'supprime tous les noms définis sauf les zones d'impression
        Next nom
        Sheets(1).Select '1ère feuille
        ActiveWorkbook.SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
        ActiveWorkbook.Close False 'ferme le document
    End If
Next c
End Sub

Dans le document créé tous les noms définis sont supprimés sauf les zones d'impression.

A+

Bonjour,

Merci pour votre retour,

Je vous rejoins le fichier modifier et si c'est possible, pouvez vous SVP modifier la macro de telle sorte que le TCD et la requête n'ont plus de connexion avec le fichier source lors de sa duplication,

Sur le fichier joint les formules ne sont plus remplacées par leurs valeurs, et donc par exemple sur l'onglet G j'ai la formule pour déterminer "P:\P-E\C G\B CR\Z\2020\CLASSE 3" et cela me renvoi #NOM? dans la cellule P1 et non sa valeur,

Merci pour tout, car je n'aurai jamais su aboutir à un tel résultat sans vos connaissances en VBA,

Merci encore mille fois,

Cordialement,

job75 · 5 Décembre 2021

Ça devient un peu casse-bonbon mais voyez ce fichier (5) :

VB:

For Each c In P.Columns(1).Cells
    Set w = ThisWorkbook.Sheets(CStr(c))
    w.Visible = xlSheetVisible 'si la feuille est masquée
    If c(1, 2) <> c(0, 2) Then 'compare avec le nom de fichier au-dessus
        w.Copy 'crée un nouveau document
    Else
        w.Copy After:=ActiveSheet 'ajoute la feuille copiée
    End If
    Set Q = w.UsedRange 'plage copiée
    On Error Resume Next 'si aucune SpecialCell
    Set Q = Q.SpecialCells(xlCellTypeFormulas)
    On Error GoTo 0
    For Each Q In Q.Areas
        Range(Q.Address) = Q.Value 'copie les valeurs
    Next Q
    If c(1, 2) <> c(2, 2) Then 'compare avec le nom de fichier au-dessous
        For Each nom In ActiveWorkbook.Names
            sup = True
            For Each F In ActiveWorkbook.Worksheets
                If nom.Name Like F.Name & "!*" Or nom.Name Like "'" & F.Name & "'!*" Then sup = False
            Next F
            If sup Then nom.Delete 'supprime le nom sauf s'il est défini dans une feuille du document créé
        Next nom
        Sheets(1).Select '1ère feuille
        ActiveWorkbook.SaveAs chemin & c(1, 2), 51 'enregistre avec l'extension .xlsx
        ActiveWorkbook.Close False 'ferme le document
    End If
Next c

Il faut conserver tous les noms définis dans les feuilles du document créé.

ZZ59264 · 6 Décembre 2021

Bonjour,

Oui désolé pour toutes ces demandes, après avoir testé ça marche parfaitement,

Je vais cependant chercher comment modifier le code pour couper la liaison sur le tableau croisé,

Merci pour tout et du temps consacré,

Cordialement,

job75 · 6 Décembre 2021

Bonjour ZZ59264, le forum,

Avec ce fichier (6) les TCD et les tableaux structurés sont convertis en plages :

VB:

    For Each o In ActiveSheet.PivotTables 'TCD
        With o.TableRange2
            s = .Value 'mémorise les valeurs
            .ClearContents 'efface le TCD
            .Value = s 'restitue les valeurs
        End With
    Next o
    For Each o In ActiveSheet.ListObjects 'tableaux structurés
        o.Unlist 'convertit en plage
    Next o
    Range(w.UsedRange.Address) = w.UsedRange.Value 'supprime les formules

Je pense qu'on a fait le tour de la question.

A+

XL 2016 VBA decomposer fichier en plusieurs fichiers avec critères et sans liaison

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

Pièces jointes

XLDnaute Barbatruc

Pièces jointes

XLDnaute Occasionnel

XLDnaute Barbatruc

Pièces jointes

Discussions similaires

Partager cette page

Statistiques des forums