Création d'onglets en fonction de filtres

[thenthelo]

Bonjour,

Je viens faire appel à vos connaissances pour m’aider à gagner un temps précieux sur le sujet suivant.
J’ai une base de donnée que je voudrais scinder (en gardant intacte la base de donnée) en autant d’onglets qu’il y a de valeurs contenues dans la colonne B ‘Continents’ et dans la colonne C ’Pays’.
Je voudrais donc les onglets : Europe-Fr, Europe-UK, Europe-ES et ainsi de suite.
Pour compliquer les choses :
- il faut, pour que les formules des col J et K continuent à marcher, que les lignes au dessus de la base de donnée (ligne 2 dans l’exemple) soient bien reprises dans chaque onglet.
- il faudrait que les lignes 24 à 26 se retrouvent dans chaque onglet juste en dessous de la dernière ligne.
- que la mise en page de la base de données soit identique dans tous les onglets créés (pied de pages, format,…).

Dans la réalité ma base de données est à splitter en plus de 150 onglets, une vraie galère à faire à la main….

Merci d’avance pour votre aide.

 

[mapomme]

Re : Création d'onglets en fonction de filtres

Bonjour thenthelo, klin89, bhbh,

Préférez la version v2 un peu plus rapide et moins vérolée ICI.

 

[klin89]

Re : Création d'onglets en fonction de filtres

Bonsoir mapomme, thenthelo, le forum

A tester :

Option Explicit

Sub CréationFeuilles()
Dim dico As Object, i As Long, txt As String, e, temp As String
    Application.ScreenUpdating = False
    Set dico = CreateObject("Scripting.Dictionary")
    dico.CompareMode = 1
    With Sheets("Feuil1").Range("A4").CurrentRegion
        With .Resize(.Rows.Count - 3)
            For i = 2 To .Rows.Count
                txt = .Rows(i).Cells(2).Value & _
                      "," & .Rows(i).Cells(3).Value
                If Not dico.exists(txt) Then
                    Set dico(txt) = Union(.Rows(1), .Rows(i))
                Else
                    Set dico(txt) = Union(dico(txt), .Rows(i))
                End If
            Next
        End With
    End With
    For Each e In dico
        temp = Join$(Split(e, ","), " - ")
        If Not IsSheetExists(temp) Then
            Sheets.Add(after:=Sheets(Sheets.Count)).Name = temp
        End If
        With Sheets(temp)
            .Cells.Clear
            Sheets("Feuil1").Rows(2).Copy .Cells(1).Offset(1)
            dico(e).Copy
            .Cells(1).Offset(3).PasteSpecial
            Sheets("Feuil1").Range("A4").CurrentRegion.Offset(Sheets("Feuil1").Range("A4").CurrentRegion.Rows.Count - 3).Resize(3).Copy
            .Range("A4").CurrentRegion.Offset(.Range("A4").CurrentRegion.Rows.Count).Resize(1).PasteSpecial
        End With
    Next
    Set dico = Nothing
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
End Sub


Function IsSheetExists(feuille As String) As Boolean
    On Error Resume Next
    IsSheetExists = Len(Sheets(feuille).Name)
    On Error GoTo 0
End Function

klin89

 

[Cousinhub]

Re : Création d'onglets en fonction de filtres

Bonsoir,

Bonsoir mapomme et klin89

Une autre proposition, en utilisant un filtre avancé (ou élaboré)

@thenthelo : le code est commenté, maintenant, je ne saisis pas trop l'utilité, tout comme mapomme, de la recopie de la zone rouge....

le code :

Sub repartition()
Dim Sh As Worksheet, ShBase As Worksheet, ShMod As Worksheet
Dim LesZones As Object
Dim Cel As Range, Plg As Range, Plg2 As Range
Dim DerLig As Long, DerLig2 As Long
Dim It
With Application: .ScreenUpdating = False: .DisplayAlerts = False: End With 'on supprime le raffraichissement et les alertes
Set ShBase = Sheets("base"): Set ShMod = Sheets("modele") 'on définit les onglets
Set LesZones = CreateObject("Scripting.Dictionary") 'on créé un objet Dictionary
For Each Sh In Worksheets
    If Sh.Name <> ShBase.Name And Sh.Name <> ShMod.Name Then Sh.Delete 'on supprime les onglets qui ne nous servent plus
Next Sh
With ShBase
    DerLig = .Cells(Rows.Count, 2).End(xlUp).Row 'définition de la dernière ligne de la base
    Set Plg = .Range("A4:K" & DerLig): Set Plg2 = .Range(.Cells(DerLig + 1, 1), .Cells(DerLig + 3, 11))
            'définition de la base de données et de la zone rouge à recopier
    .Range("R1").Value = .Range("B4").Value: .Range("S1").Value = .Range("C4").Value
            'on met les titres des critères, pour le filtre avancé
    For Each Cel In .Range("B5:B" & DerLig) 'on balaie toutes les cellules de la colonne B de la base
        LesZones(Cel.Value & "-" & Cel.Offset(, 1).Value) = Cel.Value & "-" & Cel.Offset(, 1).Value
                'on remplit l'objet Dictionnary sans doublons, avec les continents et les pays
    Next Cel
End With
For Each It In LesZones.Items 'on va traiter tous les ensembles "pays"-"continents" du Dictionary
    Sheets("modele").Copy After:=Sheets(Sheets.Count) 'on fait une copie de l'onglet "modele"
    ShBase.Range("R2").Value = Split(It, "-")(0): ShBase.Range("S2").Value = Split(It, "-")(1)
            'on met les critères dans la zone de critères
            'dans R2, le continent, dans S2 le pays
    With ActiveSheet 'l'onglet qu'on vient de créer
        .Name = It 'on le nomme "Continent-Pays"
        Plg.AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=ShBase.Range("R1:S2"), CopyToRange:=.Range("A4:K4")
                'on fait le filtre avancé (ou élaboré) de la base de données, avec les critères
                'qu'on extrait vers l'onglet nouvellement créé
        DerLig2 = .Cells(Rows.Count, 2).End(xlUp).Row + 1
            'on définit la dernière ligne remplie +1 de ce nouvel onglet
        Plg2.Copy .Cells(DerLig2, 1)
            'on recopie la zone rouge
    End With
Next It
With ShBase
    .Range("R1:S2").Clear 'on nettoie la zone de critères
    .Select 'on revient sur l'onglet "base"
End With
End Sub

Bon courage, et bonne soirée

 

[mapomme]

Re : Création d'onglets en fonction de filtres

Bonjour thenthelo, klin89, bhbh, Exene,

Préférez la version v2 un peu plus rapide et moins vérolée ICI.

 

[mapomme]

Re : Création d'onglets en fonction de filtres

Bonjour à tous,

Dans le fichier exemple de thenthelo la Mauritanie appartient à deux continents !?!?? Pour tenir compte de ce fait, voulu ou non, j'ai fait une version v2 qui affiche, le cas échéant, un onglet "Anomalies". Cette version v2 devrait être plus véloce que mes précédentes versions sans toutefois atteindre la vitesse d’exécution du filtre élaboré - version bhbh -. Cette version n'utilise ni filtre automatique ni filtre élaboré.

Attention: Avant la ventilation, on détruit toutes les feuilles dont le nom comprend un tiret "-". Donc ne pas inclure de tiret dans le nom d'une feuille qu'on veut conserver.

Sub VentilerBase()
Dim dico, tablo, Plage(1 To 3) As Range, i&, derLigPays&, RefData, RefPage, elem, aux

Application.ScreenUpdating = False: Application.DisplayAlerts = False

For Each elem In ThisWorkbook.Worksheets
  If InStr(elem.Name, "-") > 0 Then elem.Delete
Next elem

With Sheets("Feuil1")
  RefData = "@RefData": On Error Resume Next: Sheets(RefData).Delete: On Error GoTo 0
  .Copy after:=Sheets(Sheets.Count): ActiveSheet.Name = RefData
  RefPage = "@RefPage": On Error Resume Next: Sheets(RefPage).Delete: On Error GoTo 0
  .Copy after:=Sheets(Sheets.Count): ActiveSheet.Name = RefPage
  Sheets(RefPage).UsedRange.ClearContents
  Sheets(RefPage).Shapes("btVentiler").Delete
End With

With Sheets(RefData)
  Set Plage(1) = .Range("a1:k4")
  derLigPays = .Cells(Rows.Count, "c").End(xlUp).Row
  Set Plage(2) = .Range("a5:k" & derLigPays)
  Plage(2).Sort key1:=.[b5], order1:=xlAscending, key2:=.[c5], order2:=xlAscending, Header:=xlNo
  Set Plage(3) = .Range(.Cells(derLigPays + 1, "a"), .Cells(Rows.Count, 1).End(xlUp).Offset(, 10))
  tablo = .Range(.Cells(1, "b"), .Cells(derLigPays, "c"))
  Set dico = CreateObject("Scripting.Dictionary"): dico.CompareMode = vbTextCompare
  For i = 5 To UBound(tablo)
    elem = tablo(i, 1) & "-" & tablo(i, 2)
    If Not dico.Exists(elem) Then dico(elem) = Array(i, i) Else dico(elem) = Array(dico(elem)(0), i)
  Next i
End With

For Each elem In dico.Keys
  Application.StatusBar = elem
  Sheets(RefPage).Copy after:=Sheets(Sheets.Count): ActiveSheet.Name = elem
  ActiveSheet.Cells.Delete
  With Sheets(RefData)
    Plage(1).Copy ActiveSheet.[a1]
    .Range(.Cells(dico(elem)(0), "a"), .Cells(dico(elem)(1), "k")).Copy ActiveSheet.[a5]
    Plage(3).Copy ActiveSheet.Range("a" & Rows.Count).End(xlUp)(2, 1)
  End With
Next elem

dico.RemoveAll
For i = 5 To UBound(tablo)
  elem = tablo(i, 2)
  If Not dico.Exists(elem) Then
    dico(elem) = tablo(i, 1)
  Else
    If InStr(dico(elem), tablo(i, 1)) = 0 Then dico(elem) = dico(elem) & "/" & tablo(i, 1)
  End If
Next i
On Error Resume Next: Sheets("Anomalies").Delete: On Error GoTo 0
Sheets.Add after:=Sheets("Feuil1"): ActiveSheet.Name = "Anomalies"
Range("a1") = "Code pays": Range("b1") = "Continents": i = 1
For Each elem In dico.Keys
  If InStr(dico(elem), "/") > 1 Then
    i = i + 1: Cells(i, 1) = elem
    aux = Split(dico(elem), "/")
    Cells(i, 2).Resize(, UBound(aux) + 1) = aux
  End If
Next elem
If i = 1 Then Sheets("Anomalies").Delete Else Sheets("Anomalies").Tab.Color = 192

On Error Resume Next: Sheets(RefData).Delete: On Error GoTo 0
On Error Resume Next: Sheets(RefPage).Delete: On Error GoTo 0
Application.StatusBar = False: Application.DisplayAlerts = True
Sheets("Feuil1").Activate: MsgBox "Ventilation Terminée"
End Sub

 

[thenthelo]

Re : Création d'onglets en fonction de filtres

Bonsoir à tous et merci pour vos réponses

Alors tout d'abord la Mauritanie en double est une erreur de ma part lors de la création du petit fichier d'exemple. Dans mon cas pratique ce genre d'anomalie ne peut pas exister.
Vous vous demandiez aussi à quoi servent les lignes en rouge. Elles serviront aux destinataires des fichiers qui pourront compléter avec de nouvelles données.
Je pense partir sur la solution proposée par mapomme. Je suis complément ignarde en visual basic mais je devrais arriver à l'adapter à mon cas réel. Je ne pourrai faire ça que lundi au boulot.

Vu votre efficacité je crois que je vais abuser de vos compétences :
- j'aimerais que pour chaque nouvel onglet créé par la macro de ventilation, un nouvel onglet soit créé et qu'il corresponde à un TCD de cet onglet. Cela va donc doubler tous les onglets. Par contre j'aimerais que les TCD créés aient les champs précis et une mise en page bien spécifique. Il faut donc peut être créer un modèle avant avec la feuil1 par exemple ? Si cela est trop compliqué à mettre en oeuvre je peux accepter que le TCD soit en dessous de la zone rouge des onglets précédemment créés. Dites moi si ce n'est pas clair....
- une nouvelle macro qui me permettrait de créer automatiquement des fichiers avec les onglets précédemment créés. Exemple un fichier avec tous les onglets Europe-xxxx, un autre avec les Asie-xxxx.

Un grand merci !

 

[mapomme]

Re : Création d'onglets en fonction de filtres

Bonjour thenthelo, à tous,

(...) une nouvelle macro qui me permettrait de créer automatiquement des fichiers avec les onglets précédemment créés. Exemple un fichier avec tous les onglets Europe-xxxx, un autre avec les Asie-xxxx. (...)

Voir si la v3 peut convenir...

(...) j'aimerais que pour chaque nouvel onglet créé par la macro de ventilation, un nouvel onglet soit créé et qu'il corresponde à un TCD de cet onglet. Cela va donc doubler tous les onglets. Par contre j'aimerais que les TCD créés aient les champs précis et une mise en page bien spécifique. Il faut donc peut être créer un modèle avant avec la feuil1 par exemple ? (...)

Il nous faudrait un fichier avec un exemple de TCD

 

[thenthelo]

Re : Création d'onglets en fonction de filtres

Bonjour mapomme,

Merci pour la macro d’enregistrement. Par contre serait il possible de l’adapter pour que les fichiers ne soient pas supprimés du premier fichier ? Je n’ai pas réussi à le faire (je suis nulle !).

Voici un exemple de TCD dans le fichier joint.

Finalment je suis partie sur la v2 que tu avais faite car la 3 est un peu trop complexe pour moi. Et j’ai du supprimer le bouton de lancement (pourtant bien pratique) car je ne sais pas lui donner un nom comme repris ensuite dans la ligne de macro qui supprime le dit bouton !

 

[thenthelo]

Re : Création d'onglets en fonction de filtres

Finalement la macro de ventilation ne marche pas car je me suis trompée dans ma demande.
En fait le champ que j’avais appelé Pays dans mon exemple peut se retrouver dans tous les autres pays.

S’il l’on repart sur ce nouveau fichier il me faudrait les onglets Europe-1 ; Europe-2 ; Afrique-1 ;…. avec toujours les filtres sur Continent puis sur code

Je ne suis pas fichue de modifier la macro en conséquence....

 

[mapomme]

Re : Création d'onglets en fonction de filtres

Bonsoir thenthelo,

J'ai refait une version v3 avec le nouveau fichier:

• les onglets 'continent-x' restent dans le fichier après transfert dans les classeurs par continent
• les formes de feuil1 servant à lancer les macros sont supprimées dans les onglets 'continent-x' quelque soit leur nom
• la feuille "Anomalies a été supprimée puisqu'elle devient inutile (un même code pouvant se retrouver dans plusieurs continents)
• le code a été commenté

Il faudrait refaire l'exemple du TCD puisque des champs ont été supprimés depuis la première version du fichier.

 

[thenthelo]

Re : Création d'onglets en fonction de filtres

Merci pour cette dernière version qui répond bien à mon besoin et que j'ai su adapter à mon fichier réel (qui contient beaucoup plus de colonnes et de lignes) grâce aux commentaires détaillés.
La cerise sur le gâteau serait de tout de même conserver la mise en forme des colonnes (taille de certaines colonnes).

Pour le TCD voici le même fichier avec le TCD qui va bien.
S'il est plus simple de procéder avec le TCD sur la même feuille (sans passer par de nouvelles feuilles) cela ne me pose pas de problème (par exemple en le mettant à partir de L4 de Feuil1).

 

[mapomme]

Re : Création d'onglets en fonction de filtres

Bonsoir thenthelo ,

La version avec la création de la feuille TCD associée à chaque couple (continent,code).
La taille des colonnes devraient être conservée.

Si j'ai oublié ou mal interprété un point, me le signaler.

 

[thenthelo]

Re : Création d'onglets en fonction de filtres

Bonjou mapomme,

La macro ne fonctionne pas, avec le message suivant "Variable non définie" sur la ligne suivante :
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rgSourceTCD _
, Version:=xlPivotTableVersion14).

Que dois-je faire ?

 

[thenthelo]

Re : Création d'onglets en fonction de filtres

Bonjou mapomme,

La macro ne fonctionne pas, avec le message suivant "Variable non définie" sur la ligne suivante :
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=rgSourceTCD _
, Version:=xlPivotTableVersion14).

Que dois-je faire ?

Ah ben j'ai compris en fait c'est la version Excel 2007 que nous avons au bureau (ce qu'on est ringards !!!). Du coup j'ai modifié le 14 en 12. Et ca à l'air de très bien marcher