Ventiler une base en feuilles et onglets - VBA

Lilma

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

Pièces jointes

  • Test Fichiers sources - v12.xlsm
    16 KB · Affichages: 57

Staple1600

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

XLDnaute Nouveau
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 2:Deux onglets supplémentaires ont été créés en plus sur la base du critère 2

Merci beaucoup pour ton aide.
 

Pièces jointes

  • ALAIN.xlsm
    22.6 KB · Affichages: 56

Calvus

XLDnaute Barbatruc
Bonjour,

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

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

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

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

Staple1600

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

Discussions similaires

Statistiques des forums

Discussions
311 727
Messages
2 081 962
Membres
101 852
dernier inscrit
dthi16088