Adaptation code pour créer d'onglet

Le 24/01/2018 à 18:46

Bonjour à tous,

j'essaie d'adapter le code ci dessous de créer autant d'onglet qu'il y a de valeurs différentes dans la colonne Y "Nom du départ" de ma feuille référence "Cumul anomalies" et recopier les lignes correspondantes. La partie création d'onglet fonctionne mais pas la copie des lignes, la macro ne recopie que les valeurs des deux dernières colonnes...

Voici le code que j'essai d'adapter:

Sub k_Onglet()
Dim Dico, k, i
Dim C As Range
Dim n As Integer, LigneC As Integer
    Set Dico = CreateObject("Scripting.dictionary")
    ' Application.ScreenUpdating = False
    With Worksheets("Cumul anomalies")
        For Each C In .Range("Y8:Y" & .Range("A" & Rows.Count).End(xlUp).Row)
            If Not Dico.Exists(C.Value) Then Dico.Add C.Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        i = Dico.items
        For n = 0 To Dico.Count - 1
            LigneC = 1
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = k(n)
            For Each C In .Range("Y1:Y" & .Range("A" & Rows.Count).End(xlUp).Row)
                If C = k(n) Then
                    C.Offset(0, 2).Resize(, 5).Copy ActiveSheet.Range("A" & LigneC)
                    LigneC = LigneC + 1
                End If
            Next C
        Next n
    End With
End Sub

Mais connaissances en VBA sont trop justes.

J'aimerai par la même occasion recopier les 8 premières lignes sur chaque feuille qui constituent mon en-tête.

Merci pour votre aide.

13fichier-forum-aps-tri.zip (36.91 Ko)
Le 24/01/2018 à 19:06

Bonsoir

Essaie ce code que tu mets dans un module :

Sub k_Onglet()
Dim Dico, k, i
Dim C As Range
Dim n As Integer, LigneC As Integer
    Set Dico = CreateObject("Scripting.dictionary")
    ' Application.ScreenUpdating = False
    With Worksheets("Cumul anomalies")
        For Each C In .Range("Y8:Y" & .Range("A" & Rows.Count).End(xlUp).Row)
            If Not Dico.Exists(C.Value) Then Dico.Add C.Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        i = Dico.items
        For n = 0 To Dico.Count - 1
            LigneC = 1
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = k(n)
            For Each C In .Range("Y1:Y" & .Range("A" & Rows.Count).End(xlUp).Row)
                If C = k(n) Then
                    C.Offset(0, -24).Resize(, 28).Copy ActiveSheet.Range("A" & LigneC)
                    LigneC = LigneC + 1
                End If
            Next C
        Next n
    End With
End Sub

Cela va-t-il mieux ??

A+

Le 24/01/2018 à 19:08

bonsoir,

une proposition d'adaptation du code

Sub k_Onglet()
Dim Dico, k, i
Dim C As Range
Dim n As Integer, LigneC As Integer
    Set Dico = CreateObject("Scripting.dictionary")
    ' Application.ScreenUpdating = False
    With Worksheets("Cumul anomalies")
        For Each C In .Range("Y8:Y" & .Range("A" & Rows.Count).End(xlUp).Row)
            If Not Dico.Exists(C.Value) Then Dico.Add C.Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        i = Dico.items
        For n = 0 To Dico.Count - 1
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = k(n)
            LigneC = 8
            .Rows("1:7").Copy ActiveSheet.Range("A1")
            For Each C In .Range("Y1:Y" & .Range("A" & Rows.Count).End(xlUp).Row)
                If C = k(n) Then
                    C.EntireRow.Copy ActiveSheet.Range("A" & LigneC)
                    LigneC = LigneC + 1
                End If
            Next C
        Next n
    End With
End Sub
Le 24/01/2018 à 20:04

Bonsoir à tous,

Si l'on souhaite utiliser la méthode Copy de l'objet Range, autant associer cet objet Range directement à la clé du dictionnaire

.....
Set dico = CreateObject("Scripting.Dictionary")
dico.CompareMode = 1
With Sheets("Cumul anomalies").Range("a7").CurrentRegion
    For i = 2 To .Rows.Count
        If Not dico.Exists(.Cells(i, 25).Value) Then
            Set dico(.Cells(i, 25).Value) = Union(.Rows(1), .Rows(i))
        Else
            Set dico(.Cells(i, 25).Value) = Union(dic(.Cells(i, 25).Value), .Rows(i))
        End If
    Next
End With
....

Ensuite lors de la création des différentes feuilles, on utilisera la méthode Copy pour restituer l'item associé à chaque clé.

klin89

Le 26/01/2018 à 09:50

Merci à tous, désolé pour la répons tardive,

la macro de h2s04 fonctionne parfaitement.

Je souhaiterai l'adapter une nouvelle fois pour faire une création d'onglet à partir des valeurs de la colonne "Q".

J'ai donc modifié la ligne ainsi:

        For Each C In .Range("Q8:Y" & .Range("A" & Rows.Count).End(xlUp).Row)

J’aimerai également ajouter un "R-xxx" où xxx est le nom de l’onglet.

Merci de votre aide.

A vous lire

Le 26/01/2018 à 10:58

Bonjour,

1 une remarque

quand tu mets range("Q8:Y" & dl) tu vas prendre en considération toutes les valeurs de la plage (donc valeurs dans les colonnes Q,R,S,T,U,V,W,X,Y), je doute que ce soit ce que tu veux.

2 le problème

comme l'indique le message d'erreur, le nom pour une feuille n'est pas correct. la macro essaie de créer un onglet sur base d'une valeur trouvée dans la plage qui n'est pas un nom de feuille correct.

Le 26/01/2018 à 11:23

Merci h2s04,

les points 1 et 2 sont réglés.

Par contre il n'y a pas de recopie des données dans les onglets correspondants

Et je ne vois pas comment ajouter un "R-xxx" où xxx est le nom de l'onglet crée automatiquement.

A te lire.

Le 26/01/2018 à 11:27

Re,

je viens de régler le problème de recopie des données....une étourderie.

Il me reste à ajouter un "R-xxx" où xxx est le nom de l'onglet crée automatiquement, pour être parfait.

A te lire.

Le 26/01/2018 à 11:42

Bonjour,

où faut-il ajouter un R-xxx ?

Le 26/01/2018 à 11:49

Re,

il faudrait ajouter un "R-xxx" où xxx est le nom de l'onglet crée automatiquement, pour être parfait.

ex: onglet crée "SANNER" devient "R-SANNER".

A te lire.

Le 26/01/2018 à 11:58

re-bonjour,

remplace cette instruction

ActiveSheet.Name = k(n)

par ceci

ActiveSheet.Name = "R-" & k(n)
Le 26/01/2018 à 12:09

Merci h2s04 pour ton aide et ta rapidité,

tout fonctionne parfaitement.

@+ pour de nouvelles avenures

Le 01/03/2018 à 16:26

Bonjour à tous,

pour ne pas créer un nouveau sujet j'ai rouvert celui ci pour une petite adaptation de mon code.

Je souhaite que mon onglet créer prenne le nom la cellule en "I" suivi du nom de la cellule en "K".

Un exemple pour être plus clair:

le code:

Sub POI_OngletDpt()
' tri onglet "POI-POSTE" par Dpt
Dim Dico, k, i
Dim C As Range
Dim plage As Range
Dim N As Integer, LigneC As Integer
' sélection de la feuil "Cumul anomalies"
Worksheets("POI_POSTE").Select
    Set Dico = CreateObject("Scripting.dictionary")
    ' Application.ScreenUpdating = False
    With Worksheets("POI_POSTE")
        For Each C In .Range("I2:I" & .Range("A" & Rows.Count).End(xlUp).Row)
            If Not Dico.Exists(C.Value) Then Dico.Add C.Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        i = Dico.items
        For N = 0 To Dico.Count - 1
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = k(N)
            LigneC = 2
            .Rows("1:1").Copy ActiveSheet.Range("A1")
            For Each C In .Range("I1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
                If C = k(N) Then
                    C.EntireRow.Copy ActiveSheet.Range("A" & LigneC)
                    LigneC = LigneC + 1
                End If
            Next C
        Next N
    End With
End Sub

ce qui me donne comme nom d'onglet "VARETC0014", etc.... mais je souhaiterai "VARETC0014 - LAGUNE"

7fichier-forum.xlsx (10.64 Ko)
Le 01/03/2018 à 17:33

Bonjour

Essaie ce code :

Sub POI_OngletDpt()
' tri onglet "POI-POSTE" par Dpt
Dim Dico, k, i
Dim C As Range
Dim plage As Range
Dim N As Integer, LigneC As Integer
' sélection de la feuil "Cumul anomalies"
Worksheets("POI_POSTE").Select
    Set Dico = CreateObject("Scripting.dictionary")
    ' Application.ScreenUpdating = False
    With Worksheets("POI_POSTE")
        For Each C In .Range("I2:I" & .Range("A" & Rows.Count).End(xlUp).Row)
            If Not Dico.Exists(C.Value & "-" & C.Offset(0, 2).Value) Then Dico.Add C.Value & "-" & C.Offset(0, 2).Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        i = Dico.items
        For N = 0 To Dico.Count - 1
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = k(N)
            LigneC = 2
            .Rows("1:1").Copy ActiveSheet.Range("A1")
            For Each C In .Range("I1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
                If C = k(N) Then
                    C.EntireRow.Copy ActiveSheet.Range("A" & LigneC)
                    LigneC = LigneC + 1
                End If
            Next C
        Next N
    End With
End Sub

Dis-moi

A+

Le 02/03/2018 à 09:24

Merci Patty5046,

désolé pour cette réponse un peu tardive, le code modifié me créée bien l'onglet sous la forme que je souhaite.

Mais il ne copie plus les données dans chaque onglet, je pense que cela vient du fait qu'il n'y est plus de correspondance entre le nom de ma colonne "I" et le nom de l'onglet.

Y aurait il un moyen de corriger?

A te lire.

Le 02/03/2018 à 11:19

Bonjour

Essaie comme cela :

Sub POI_OngletDpt()
' tri onglet "POI-POSTE" par Dpt
Dim Dico, k, i
Dim C As Range
Dim plage As Range
Dim n As Integer, LigneC As Integer
' sélection de la feuil "Cumul anomalies"
Worksheets("POI_POSTE").Select
    Set Dico = CreateObject("Scripting.dictionary")
    ' Application.ScreenUpdating = False
    With Worksheets("POI_POSTE")
        For Each C In .Range("I2:I" & .Range("A" & Rows.Count).End(xlUp).Row)
            If Not Dico.Exists(C.Value & "-" & C.Offset(0, 2).Value) Then Dico.Add C.Value & "-" & C.Offset(0, 2).Value, C.Offset(0, 1).Value
        Next C
        k = Dico.keys
        i = Dico.items
        For n = 0 To Dico.Count - 1
            Sheets.Add After:=Sheets(Sheets.Count)
            ActiveSheet.Name = k(n)
            LigneC = 2
            .Rows("1:1").Copy ActiveSheet.Range("A1")
            For Each C In .Range("I1:I" & .Range("A" & Rows.Count).End(xlUp).Row)
                pos_tiret = InStr(k(n), "-")
                If C = Left(k(n), pos_tiret - 1) Then
                    C.EntireRow.Copy ActiveSheet.Range("A" & LigneC)
                    LigneC = LigneC + 1
                End If
            Next C
        Next n
    End With
End Sub

Dis-moi

A+

Le 02/03/2018 à 11:30

Re,

je viens de faire le test c'est exactement ce qu'il me faut.

Merci pour le coup de "code"

Le 02/03/2018 à 11:51

Contente pour toi

Bonne continuation

Bye

Rechercher des sujets similaires à "adaptation code creer onglet"