Ventiler une base en feuilles et onglets - VBA

Lilma · 13 Janvier 2018

Bonjour à tous,

Débutant en VBA, je me lance dans mon 1er gros projet. J’ai beau éplucher les forums je ne trouve pas la solution

Mon problème : Je dispose d’une base de données (TEST). Je souhaiterais :

- Étape 1 : Ventiler la base TEST sur plusieurs classeurs sur la base du champ CRITERE 1 (colonne N). Ces feuilles doivent être les mêmes que la base de données sur la forme et le fond (maintien des formules entre autre). Idéalement le classeur prendrait le nom du critère.

- Étape 2 : Sur l nouveau classeur crée, en plus du 1er onglet qui reprendrait toutes les données du CRITERE 1, il faudrait ventiler ce 1er onglet sur plusieurs autres onglets sur la base du CRITERE 2 (colonne O). Idem maintien du tableau tel qu’il est et attribution d’un nom à l’onglet sur la base du critère 2.

Cela fait 2 jours que je fais des tests dans tous les sens mais rien à faire, aucune de mes macros ne fonctionnent.

Merci par avance pour votre aide.

Lilma

Staple1600 · 13 Janvier 2018

Bonjour le fil, le forum

@Lilma [Bienvenue sur le forum]

Cela fait 2 jours que je fais des tests dans tous les sens mais rien à faire, aucune de mes macros ne fonctionnent.

Ce n'est pas une raison suffisante pour ne pas les laisser dans ton classeur exemple

Lilma · 13 Janvier 2018

Bonjour Staple1600,

Je ne voulais pas influencer les réponses en faisant partir les forumer sur une fausse piste voilà tout

Staple1600 · 13 Janvier 2018

Re

Oui mais cela nous permets de voir les pistes déjà envisagées, de "corriger" le code existant si besoin.

Autrement, on fait quoi des doublons dans la colonne N et la colonne O?
Et pourrais-tu joindre en plus un fichier exemple "résultat" pour Alain par exemple, stp?

Lilma · 13 Janvier 2018

Re,

On reporte tout peu importe qu'il y ai un doublon ou pas.
En PJ un fichier cible pour le cas de Alain.
Etape 1 : Un classeur Alain a été créé avec un onglet reprenant toutes ses lignes
Etape 2eux onglets supplémentaires ont été créés en plus sur la base du critère 2

Merci beaucoup pour ton aide.

Calvus · 13 Janvier 2018

Bonjour,

Staple1600 à dit:
Ce n'est pas une raison suffisante pour ne pas les laisser dans ton classeur exemple

Je confirme, cela m'aurait évité de refaire le code au moment où j'allais envoyer une réponse....
Double boulot donc !

Il faut te placer sur un des noms de la colonne N pour le sélectionner, puis exécuter le code.
Si tu ne le fais pas, cela générera des erreurs que je n'ai pas le temps de traiter tout de suite.
On te demande d'entrer un numéro, qui permettra l'enregistrement de plusieurs classeurs au même nom.
Ceci peut être automatisé également, mais on a tellement peu d'informations sur ce que tu souhaites réellement que c'est difficile de suggérer quelque chose.

Le code est à placer dans le code de la feuille. On pourrait le mettre dans un module, en modifiant n peu.

VB:

Option Explicit
Sub Ventiler()
'Enregistrement du Classeur----------------------------------------------------------------------------
Application.ScreenUpdating = False
Dim LePath As String, LeNom As String, numéro As String
    Range("N9").AutoFilter
        ActiveSheet.Range("$A$9:$AH$16").AutoFilter Field:=14, Criteria1:=Selection
            numéro = InputBox("Veuillez entrer un numéro pour l'enregistrement")
                LePath = "C:\Users\###A DEFINIR###\Downloads\"
                    ActiveSheet.Copy
                        LeNom = Selection & numéro & ".xlsx"
                        ActiveWorkbook.SaveAs LePath & LeNom
                    ActiveWorkbook.Close
            ActiveSheet.Range("$A$9:$AH$16").AutoFilter Field:=14
        Selection.AutoFilter
Application.ScreenUpdating = True
End Sub

ATTENTION : bien penser à modifier le chemin d'accès sur ton PC.

Je passe la main pour l'étape 2, sinon je reviendrai un peu plus tard. A la bourre maintenant.

Bonne journée.

Staple1600 · 13 Janvier 2018

Re

Dans un premier temps, on s'éclate

VB:

Sub EclaterClasseurs()
'archive :JM | 2013
'auteur macro d'origine: JoeMo - avril 2013
Dim lR&, vA As Variant, d As Object, JT As Variant, Wsht As Worksheet
Set Wsht = Sheets("TEST")
If Wsht.AutoFilterMode Then Wsht.Range("A9").AutoFilter
lR = Wsht.Range("N" & Rows.Count).End(xlUp).Row
vA = Wsht.Range("N10", "N" & lR).Value
Set d = CreateObject("Scripting.dictionary")
d.RemoveAll
For i = LBound(vA, 1) To UBound(vA, 1)
    If Not d.exists(vA(i, 1)) Then d.Add vA(i, 1), i
Next i
JT = d.keys
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = LBound(JT) To UBound(JT)
    On Error Resume Next
    Sheets(JT(i)).Delete
    On Error GoTo 0
    With Wsht
        .Range("A9").AutoFilter field:=14, Criteria1:=JT(i)
        .Range("A9").CurrentRegion.SpecialCells(xlCellTypeVisible).Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = JT(i)
        With ActiveSheet.Range("A8")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
            Wsht.Select
        End With
    End With
Next i
If Wsht.AutoFilterMode Then Wsht.Range("A9").AutoFilter
Application.DisplayAlerts = True
End Sub

Dans un second temps, on copiera les lignes 1 à 6

EDITION: Bonjour Calvus, t'avions point vu passer

Lilma · 13 Janvier 2018

Merci beaucoup à vous 2...je me rends compte que j'ai encore du boulot pour arriver à ce niveau.
Ta solution Calvus me permet de générer des classeurs et la tienne Staple1600 me permet d'automatiser l’éclatement sans présélection;
J'essaye de combiner un peu les 2

Staple1600 · 13 Janvier 2018

Re

Comme je le disais, je te propose d'y aller pas à pas
Donc mon idée est la suivante.
A partir de mon premier code, il nous faut ajouter la copie des lignes 1 à 6 et le changement de valeurs en fonction des critères.
Ensuite ceci fait, on éclatera les feuilles obtenues en N classeurs.

Lilma · 13 Janvier 2018

OK pigé.
Je viens d'ajouter une petite ligne de suppression du quadrillage pour les onglets générés. Je suis pas si nul en fait

Staple1600 · 13 Janvier 2018

Re

Suite
Donc une recopie amélioré avec cette version

VB:

Sub EclaterClasseursV2()
'archive :JM | 2013
'auteur macro d'origine: JoeMo - avril 2013
Dim lR&, vA As Variant, d As Object, JT As Variant, Wsht As Worksheet
Set Wsht = Sheets("TEST")
If Wsht.AutoFilterMode Then Wsht.Range("A9").AutoFilter
lR = Wsht.Range("N" & Rows.Count).End(xlUp).Row
vA = Wsht.Range("N10", "N" & lR).Value
Set d = CreateObject("Scripting.dictionary")
d.RemoveAll
For i = LBound(vA, 1) To UBound(vA, 1)
    If Not d.exists(vA(i, 1)) Then d.Add vA(i, 1), i
Next i
JT = d.keys
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For i = LBound(JT) To UBound(JT)
    On Error Resume Next
    Sheets(JT(i)).Delete
    On Error GoTo 0
    With Wsht
        .Range("A9").AutoFilter field:=14, Criteria1:=JT(i)
        Wsht.UsedRange.Copy
        Sheets.Add after:=Sheets(Sheets.Count)
        ActiveSheet.Name = JT(i)
        With ActiveSheet.Range("A1")
            .PasteSpecial Paste:=xlPasteColumnWidths
            .PasteSpecial Paste:=xlPasteValues
            .PasteSpecial Paste:=xlPasteFormats
            Application.CutCopyMode = False
            Wsht.Select
        End With
    End With
Next i
If Wsht.AutoFilterMode Then Wsht.Range("A9").AutoFilter
Application.DisplayAlerts = True
End Sub

Lilma · 13 Janvier 2018

Yes, merci! La recopie des lignes 1 à 6 est effective mais certaines cellules contenaient des formules et elle ne se sont pas dupliquées. Est ce normal ?

Staple1600 · 13 Janvier 2018

Re

Oui, c'est normal puisqu'on peut lire dans mon code
.PasteSpecial Paste:=xlPasteValues
Je te laisse faire la modif nécessaire

Lilma · 13 Janvier 2018

Yes C'est fait! Merci! Ca peut paraitre simple mais au moins ca me fait bosser

Staple1600 · 13 Janvier 2018

Re

C'est un peu le but , non ?
Faire bosser le demandeur à la résolution de sa question

Ventiler une base en feuilles et onglets - VBA

Lilma

XLDnaute Nouveau

Pièces jointes

Staple1600

XLDnaute Barbatruc

Lilma

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Lilma

XLDnaute Nouveau

Pièces jointes

Calvus

XLDnaute Barbatruc

Staple1600

XLDnaute Barbatruc

Lilma

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Lilma

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Lilma

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Lilma

XLDnaute Nouveau

Staple1600

XLDnaute Barbatruc

Discussions similaires