Macro creer et renommer des onglets d'apres une liste avec doublons

[quezaco]

Bonjour à tous, bonjour au forum,
Aprés de nombreuses recherches sur le forum, je n'ai pas pu trouver et encore moins pu adapter ce que je recherche à faire.
Dans une colonne "Noms", je dispose de nombreuses entrées ayant trés souvent le même nom.
Mon but est de créer autant d'onglets que de noms différents inclus dans cette colonne.
Mes données se trouvent en Feuil1.
Quelqu'un aurait-il une solution à me proposer car je n'en peux plus de créer des onglets à la main.
Ci-joint petit exemple.
Merci pour vos suggestions.

 

[Efgé]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour quezaco,
Une proposition qui crée les feuilles avec les noms/prénoms, si elles n'existent pas.

 Private Sub CommandButton1_Click()
Dim Dico As Object
Dim Data() As Variant, Plg As Variant
Dim i&
Dim F As Worksheet
Set Dico = CreateObject("Scripting.dictionary")
Plg = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp).Offset(0, 1)).Value
For i = LBound(Plg, 1) To UBound(Plg, 1)
    Dico(Plg(i, 1) & Plg(i, 2)) = Plg(i, 1)
Next i
Data = Dico.Keys
For i = LBound(Data) To UBound(Data)
    On Error Resume Next
    Set F = Sheets(Data(i))
    On Error GoTo 0
    If F Is Nothing Then Sheets.Add(after:=Sheets(Sheets.Count)).Name = Data(i)
Next i

Cordialement

 

[Softmama]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour,

Une proposition :

Sub BonOk()
Dim c As Range
If ActiveWorkbook.Sheets.Count > 1 Then
  For t = Sheets.Count To 2 Step -1
    Sheets(t).Delete
  Next
End If
Set c = Sheets(1).Range("B2")
On Error Resume Next
  Do While c <> ""
   a = Sheets(c.Text).Range("A1")
   If Err = 9 Then
     Sheets.Add After:=Sheets(Sheets.Count)
     Sheets(Sheets.Count).Name = c.Text
     Err.Clear
   End If
   Set c = c.Offset(1, 0)
  Loop
On Error GoTo 0
End Sub

cf. fichier

Edit : Bonjour Efgé, désolé, pas rafraîchi.

 

[quezaco]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour Efgé,
Votre proposition fonctionne trés bien. Néanmoins je ne souhaite extraire que les noms de la colonne B sans doublons. Pourriez-vous adapter le code et me le commenter afin de l'adapter à plusieurs fichiers ?
Merci pour votre aide

 

[Theze]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour,

Essai ceci. A mettre dans un module standard :

Sub Onglet()
    
    Dim Fe As Worksheet
    Dim Plage As Range
    Dim Cel As Range
    Dim Dico As Object
    Dim ListeCle ' As Variant
    Dim I As Integer
    Dim J As Integer
    
    'défini la plage des noms en colonne B à partir de B2 en feuille Feuil1
    With Worksheets("Feuil1")
     
        Set Plage = .Range(.Cells(2, 2), .Cells(.Rows.Count, 2).End(xlUp))
    
    End With
    
    'crée le dictionnaire
    Set Dico = CreateObject("Scripting.Dictionary")
    
    'parcour les cellules et ajoute au dico si le nom n'existe pas
    For Each Cel In Plage
    
        If Dico.exists(Cel.Value) = False Then
        
            Dico.Add Cel.Value, Cel.Value
            
        End If
        
    Next Cel
    
    'récupère les clés du dico
    ListeCle = Dico.Keys
    
    'renomme les deux feuilles si elles existent
    On Error Resume Next
    
    Set Fe = Worksheets("Feuil2")
    
    If Err.Number = 0 Then
    
        Fe.Name = ListeCle(0)
        J = J + 1
        
    End If
    
    Err.Clear
    
    Set Fe = Worksheets("Feuil3")
    
    If Err.Number = 0 Then
    
        Fe.Name = ListeCle(J)
        J = J + 1
        
    End If

   On Error GoTo 0
    
    'crée les feuilles pour chaque nom unique
    For I = J To Dico.Count - 1
        
        

        Set Fe = Worksheets.Add(, Worksheets(Worksheets.Count))
        Fe.Name = ListeCle(I)

    Next I
    
    Set Dico = Nothing

End Sub

Hervé.

 

[quezaco]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour Softmama, bonjour Theze,
Merci pour vos retours qui fonctionnent trés bien. Vous me dispensez tous trois de nombreuses heures de creations d'onglets, copies...
Encore un grand bravo et un grand merci à vous.
Pourvu que ça dure ...
A bientôt.

 

[Efgé]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Re,Bonjour Theze, Bonjour Softmama ,
Voici le code commenté et qui ne nomme les feuilles qu'avec les noms de famille.

 Private Sub CommandButton1_Click()
Dim Dico As Object
Dim Data() As Variant, Plg As Variant
Dim i&
Dim F As Worksheet
'on crée un objet dictionaire, qui récupèrera les valeurs sans doublon
Set Dico = CreateObject("Scripting.dictionary")
'On met dans un tableau VBA les noms de la colonne B et C (plus rapide pour un  grand nombre de noms)
Plg = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp).Offset(0, 1)).Value
'Pour toute les lignes du tableau
For i = LBound(Plg, 1) To UBound(Plg, 1)
    'La clé du dictionnaire est égale au nom an colonne 1 du tableau VBA (la colonne 2 de la feuille)
    Dico(Plg(i, 1)) = Plg(i, 1)
'Prochaine ligne du tableau
Next i
'On met les clés dans un autre tableau VBA
Data = Dico.Keys
'Pour chaque ligne du tableau des clés
For i = LBound(Data) To UBound(Data)
    'Si il y a une erreure on passe à la ligne suivante
    On Error Resume Next
    'On dis que F est égal à la feuille du nom de la valeur i du tableau des clés
    'si cette feuille n'existe pas il y a une erreur gérée par la ligbne précédente
    Set F = Sheets(Data(i))
    'si il y a une erreur on l'annule
    On Error GoTo 0
    ''si f n'est rien, donc si la feuille n'existe pas
    'on la crée au bout des onglets
    If F Is Nothing Then Sheets.Add(after:=Sheets(i + 1)).Name = Data(i)
'Prochaine ligne du tableau des clès
Next i
End Sub

Cordialement

 

[JCGL]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour à tous,
Re SoftMama,
Salut FG

Un peu à la bourre...
Donc je vais me contenter d'une toute petite "remarque" pour Softmama :

Application.DisplayAlerts = 0
If ActiveWorkbook.Sheets.Count > 1 Then
For t = Sheets.Count To 2 Step -1
Sheets(t).Delete
Next
Application.DisplayAlerts = 1

Pour éviter les messages à la suppression des feuilles.

A++
A + à tous

 

[Efgé]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Re, Bonjour JC
A noter qu'avec la proposition de Theze, si une feuille éxiste déja avec un nom de la liste, on plante.
Cordialement

 

[Softmama]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

re,

Oui, merci pour la remarque JCGL, je me l'étais dit pendant que je tapais le code, et j'ai oublié de le rajouter

 

[Theze]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour tout le monde,

Efgé a gentiment dit :

A noter qu'avec la proposition de Theze, si une feuille éxiste déja avec un nom de la liste, on plante.

Effectivement, j'ai oublié de géré ça car je suis toujours parti du principe que le classeur ne possédait pas d'autres feuilles que celles de base.
Désolé pour cette erreur

Hervé.

 

[quezaco]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour à tous, bonjour au forum,
Je me permets de revenir vers vous car j'essaie d'adapter deux codes pour n'en faire qu'un mais j'ai vraiment du mal.
Pourriez-vous apporter une correction car j'ai vraiment du mal
Code VBA d'aprés le fichier essai onglets du début de la discussion:


Private Sub CommandButton2_Click()
Dim Dico As Object
Dim Data() As Variant, Plg As Variant
Dim i&
Dim F As Worksheet
'on crée un objet dictionaire, qui récupèrera les valeurs sans doublon
Set Dico = CreateObject("Scripting.dictionary")
'On met dans un tableau VBA les noms de la colonne B et C (plus rapide pour un grand nombre de noms)
Plg = Range(Cells(2, 2), Cells(Rows.Count, 2).End(xlUp).Offset(0, 1)).Value
'Pour toute les lignes du tableau
For i = LBound(Plg, 1) To UBound(Plg, 1)
'La clé du dictionnaire est égale au nom an colonne 1 du tableau VBA (la colonne 2 de la feuille)
Dico(Plg(i, 1)) = Plg(i, 1)
'Prochaine ligne du tableau
Next i
'On met les clés dans un autre tableau VBA
Data = Dico.Keys
'Pour chaque ligne du tableau des clés
For i = LBound(Data) To UBound(Data)
'Si il y a une erreure on passe à la ligne suivante
On Error Resume Next
'On dis que F est égal à la feuille du nom de la valeur i du tableau des clés
'si cette feuille n'existe pas il y a une erreur gérée par la ligbne précédente
Set F = Sheets(Data(i))
'si il y a une erreur on l'annule
On Error GoTo 0
''si f n'est rien, donc si la feuille n'existe pas
'on la crée au bout des onglets
If F Is Nothing Then Sheets.Add(after:=Sheets(i + 1)).Name = Data(i)
'Prochaine ligne du tableau des clès
Next i
'on crée un objet dictionaire, qui récupèrera les valeurs sans doublon
Set Dico = CreateObject("Scripting.dictionary")
'On met dans un tableau VBA les noms de la colonne B et C (plus rapide pour un grand nombre de noms)
Plg = Range(Cells(2, 3), Cells(Rows.Count, 3).End(xlUp).Offset(0, 1)).Value
'Pour toute les lignes du tableau
For i = LBound(Plg, 1) To UBound(Plg, 1)
'La clé du dictionnaire est égale au nom an colonne 1 du tableau VBA (la colonne 2 de la feuille)
Dico(Plg(i, 1)) = Plg(i, 1)
'Prochaine ligne du tableau
Next i
'On met les clés dans un autre tableau VBA
Data = Dico.Keys
'Pour chaque ligne du tableau des clés
For i = LBound(Data) To UBound(Data)
'Si il y a une erreure on passe à la ligne suivante
On Error Resume Next
'On dis que F est égal à la feuille du nom de la valeur i du tableau des clés
'si cette feuille n'existe pas il y a une erreur gérée par la ligbne précédente
Set F = Sheets(Data(i))
'si il y a une erreur on l'annule
On Error GoTo 0
''si f n'est rien, donc si la feuille n'existe pas
'on la crée au bout des onglets
If F Is Nothing Then Sheets.Add(after:=Sheets(i + 1)).Name = Data(i)
'Prochaine ligne du tableau des clès
Next i
For Each ws In Sheets
If ws.Name <> "Feuil1" Then
With ws
.Cells.Clear
.Range("A1") = "Noms"
.Range("A2") = ws.Name
With Sheets("Feuil1")
.Range("A1:X100001").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("A1:A2"), CopyToRange:=ws.Range("A4")
If ws.Name <> "Feuil1" Then
With ws
.Cells.Clear
.Range("A1") = "Prenoms"
.Range("A2") = ws.Name
With Sheets("Feuil1")
.Range("A1:X100001").AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=ws.Range("A1:A2"), CopyToRange:=ws.Range("A4")
End With
.Rows("1:3").Delete
End With
End If
End Sub

D'avance merci

 

[Efgé]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonjour quezaco, le fil,

EDIT:
Après consultation des rûnes magiques, je pense que la nouvelle question n'a plus rien a voir avec le début du fil.
Ouvre une nouvelle discussion, en metant un exemple et en expliquant, clairement, ta demande...
Cordialement

 

[quezaco]

Re : Macro creer et renommer des onglets d'apres une liste avec doublons

Bonsoir Efgé,
J'essaie d'adapter le code (un mix de votre cru pour 2 colonnes + un code de Kjin) pour un autre fichier comprenant une colonne pays et région.
Merci pour vos suggestions