XL 2010 création d'onglet via macro

[philmaure]

bonjour à tous,

je souhaiterai créer un onglet par valeur de la colonne E(cf fichier joint) et y déposer l'ensemble des lignes correspondants à cette valeur
exemple : créer un onglet Lyon et y couper-coller les lignes 2 à 12

Merci pour aide

cdlt
philmaure

 

[thebenoit59]

Re : création d'onglet via macro

Bonjour Philmaure.

Une première possibilité. Il y a plus léger comme procédure, mais si un jour ton tableau devrait faire des milliers de lignes, cette procédure sera optimale.

Option Explicit

Sub Création_Onglets()
Dim d As Object, t(), temp(), i%, l%, c, n$

'On enregistre le tableau dans un tableau virtuel.
With Sheets("Feuil3")
    l = .Cells.Find("*", , , , xlByRows, xlPrevious).Row
    t = .Range(.Cells(1, 1), .Cells(l, 5)).Value
End With

'On crée un index des différentes villes.
Set d = CreateObject("scripting.dictionary")
    For i = 2 To UBound(t)
        d(t(i, 5)) = d(t(i, 5)) & i & ":"
    Next i

'On va boucler les clés du dictionnaire pour créer les feuilles.
'Nous vérifions également si les feuilles n'existent pas déjà.
For Each c In d.Keys
    n = Replace(CStr(c), """", "")
    If Not OngletExiste(n) Then
        Sheets.Add After:=Sheets((Sheets.Count))
        ActiveSheet.Name = n
    End If
    With Sheets(n)
        'On recherche la dernière ligne de la feuille
        l = .[a65000].End(xlUp).Row
        'On exporte dans un tableau temporaire les lignes correspondantes
        temp = Application.Index(t, Application.Transpose(Split(d(c), ":")), Array(1, 2, 3, 4, 5))
        'Si la dernière ligne du classeur correspond à la première alors on ajoute l'en-tête
        If l = 1 And .[a1].Value = "" Then .Range("A1:E1").Value = Application.Index(t, 1, Array(1, 2, 3, 4, 5))
        'On exporte les valeurs dans la feuille
        .Cells(l + 1, 1).Resize(UBound(temp) - 1, 5).Value = temp
    End With
Next c

'On supprime les lignes dans la première feuille
Sheets("Feuil3").Rows("2:" & UBound(t)).Delete

End Sub

Function OngletExiste(Nom As String) As Boolean
    On Error Resume Next
    OngletExiste = False
    OngletExiste = Not Sheets(Nom) Is Nothing
End Function

 

[Robert]

Re : création d'onglet via macro

Bonjour Philmaure, bonjour le forum,

Essaie comme ça :

Sub Macro1()
Dim OT As Worksheet 'déclare la variable OT (Onglet de Travail)
Dim TV As Variant 'déclare la variable TV (Tableau des Valeurs)
Dim D As Object 'déclare la variable D (Dictionnaire)
Dim I As Integer 'déclare la variable I (Incrément)
Dim TT As Variant 'déclare la variable TT (Tableau Temporaire)
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim K As Byte 'déclare la variable K (incrément)
Dim J As Integer 'déclare la variable J (incrément)
Dim TL() As Variant 'déclare la variable TL (Tableau des Lignes)

Set OT = Worksheets("Feuil3") 'définit l'onglet OT
TV = OT.Range("A1").CurrentRegion 'définit le tableau des valeurs TV
Set D = CreateObject("Scripting.Dictionary") 'définit le dictionnaire D
For I = 2 To UBound(TV, 1) 'boucle sur toutes les lignes I du tableau des valeurs TV (en partant de la seconde)
    D(TV(I, 5)) = "" 'alimente le dictionnaire D avec les données en colonne 5 du tableau des valeurs TV
Next I 'prochaine ligne de la boucle
TT = D.keys 'récupère dans le tableau temporaire TT la liste des éléments du dictionnaure D sans doublon
For I = 0 To UBound(TT) 'boucle 1 : sur tous les éléments de TT
    L = 1: Erase TL 'réinitialise la variable L, efface le tableau TL
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set O = Worksheets(TT(I)) 'définit l'onglet O (génére une erreur si cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Err.Clear 'supprime l'erreur
        Sheets.Add after:=Sheets(Sheets.Count) 'ajoute un onglet en dernière position
        ActiveSheet.Name = TT(I) 'renomme l'onglet avec TT(I) comme nom
        Set O = ActiveSheet 'définit l'onglet O
    End If 'fin de la condition
    On Error GoTo 0 'anuule la gestion des erreurs
    O.Cells.ClearContents 'efface les éventuelles anciennes valeurs dans l'onget O
    For J = 2 To UBound(TV, 1) 'boucle 2 : sur toutes les lignes J du tableau des valeurs TV
        If TV(J, 5) = TT(I) Then 'condition : la la donnée ligne J colonne 5 de TV est ágale à la valeur de TT(I)
            ReDim Preserve TL(1 To 5, 1 To L) 'redimensionne le tableau des lignes TL (5 lignes, L colonnes)
            For K = 1 To 5 'boucle 3 : sur les 5 colonnes du tableau des valeurs TV
                TL(K, L) = TV(J, K) 'récupère en ligne K de TL, la valeur de la colonne K de TV (= transposition)
            Next K 'prochaine colonne de la boucle 3
            L = L + 1 'incrémente L (ajoute une colonne au tableau des lignes TL)
        End If 'fin de la condition
    Next J 'prochaine ligne de la boucle 2
    If L > 1 Then 'si L est supérieure à 1 (au moins une occurrence trouvée)
        O.Range("A1").Resize(1, 5).Value = Application.Index(TV, 1) 'renvoie la première ligne deu tableau des valeurs TV dans A1 redimensionnée
        O.Range("A2").Resize(UBound(TL, 2), UBound(TL, 1)).Value = Application.Transpose(TL) 'renvoie le tableau TL transposé dans A2 redimensionnée
    End If 'fin de la condition
Next I 'prochain élément de la boucle 1
End Sub

[Édition]
Bonjour Benoit, nos post se sont croisés...

 

[philmaure]

Re : création d'onglet via macro

re bonjour
Un grand merci à vous deux. Tout fonctionne et même au delà de ma demande puisque je m'aperçois que lorsque j'aurai d'autres sites et donc d'autres noms d'onglets vos solutions fonctionneront également.

bonne journée
Cdlt
Philmaure