Créer des feuilles a partir d'une liste sans les re créer

Le 30/12/2019 à 17:16

bonjour

je me suis inscrit sur ce forum dans l'espoir de trouver une réponse a mon problème

j'ai réussi a bricoler le travail suivant malgré mes connaissance limités en VBA

mon travail

mon but étant un fichier qui me permet

ne pas créer de redondance de feuilles en cliquant sur le bouton valider

  • si modification d'un ligne dans la feuille liste en appuyant sur le bouton valider les feuilles correspondantes se mettent a jour
  • si remplissage d'une ou de plusieurs lignes en appuyant su le bouton valider les nouvelles feuilles correspondant a ces lignes vont se crées
  • des boutons pour envoyer par email la feuille crée en pièce jointe ayant pour objet le nom de la feuille avec un message standard et des destinataires a renseigner sur la feuille modèle

je vous remercie pour l’intérêt que vous allez accordez a ce projet

slts

35essai1.xlsm (207.98 Ko)
Le 31/12/2019 à 16:45

Bonjour Timouyassup, bonjour le forum,

Peut-être comme ça :

Sub CreationFeuilleParNom()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DerLig As Long, i As Integer
Dim NO As Worksheet 'déclare la variable NO (Nouvel Onglet)

Application.ScreenUpdating = False

'******************************************************************************************
'on commence par supprimer tous les onglets de la liste pour être sûr de tout mettre à jour

Application.DisplayAlerts = False 'empêche les messages d'Excel
For Each O In Worksheets 'boucle sur tous les onglets O du classeur
    Select Case O.Name 'agit en fonction du nom de l'onglet
        Case "Modèle", "Liste" 'cas Modèle ou Liste (rien ne se passe)
        Case Else 'tous les autre cas
            O.Delete 'supprime l'onglet O
    End Select 'fin de l'action en fonction du nom de l'onglet
Next O 'prochain onglet de la boucle
Application.DisplayAlerts = True 'affiche les messages d'Excel
'******************************************************************************************

DerLig = Feuil2.Range("B" & Rows.Count).End(xlUp).Row
For i = DerLig To 4 Step -1
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set NO = Worksheets(Feuil2.Cells(i, 2)) 'définit le nouvel onglet NO (génère une erreur su cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Sheets("Modèle").Copy After:=Feuil2 'copy l'onglet modèle après l'onglet Feuil2
        ActiveSheet.Name = Feuil2.Cells(i, 2) 'renomme l'onglet actif
        Set NO = ActiveSheet 'définit le nouvel onglet NO
    End If 'fin de la condition
    On Error GoTo 0 'annule la gestion des erreurs
    NO.Range("D5") = Feuil2.Cells(i, 2)
    NO.Range("H5") = Feuil2.Cells(i, 3)
    NO.Range("D6") = Feuil2.Cells(i, 4)
    NO.Range("A8") = Feuil2.Cells(i, 5)
    NO.Range("C8") = Feuil2.Cells(i, 6)
    NO.Range("F8") = Feuil2.Cells(i, 7)
    Feuil2.Activate
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Feuil2.Shapes.Range(Array("Picture " & i - 3)).Select 'sélectionne l'image correspondante (génère une erreur si l'image n'existe pas)
    If Err <> 0 Then GoTo suite 'si une erreur a été générée, va à l'étiquette "suite"
    Selection.Copy
    NO.Activate
    NO.Range("A10").Select
    NO.Paste
    Selection.ShapeRange.IncrementLeft 260
    Selection.ShapeRange.IncrementTop 24
suite: 'étiquette
    On Error GoTo 0 'annule la gestion des erreurs
Next i
Application.ScreenUpdating = True
End Sub

Seul le dernier point n'est pas traité...

[Édition]

J'avais mal lu le titre : sans les recréer !... Il suffit de supprimer le code entre les ****

Le 01/01/2020 à 11:53

merci chef ça répond tout a fait a ma première roquette j'en suis très ravi . merci encore une fois

je vais voir la communauté pour mon second point

Le 01/01/2020 à 17:03

Re,

Je me suis rendu compte que si tu changeais de photo dans la liste, on se retrouvait avec deux photos dans l'onglet correspondant.

J'ai aussi vu un bug avec les photos nommées Picture 1, Picture 2, etc.. Ce bug a disparu en les Nommant Picture_1, Picture_2, etc..

Le code modifié :

Sub CreationFeuilleParNom()
Dim O As Worksheet 'déclare la variable O (Onglet)
Dim DerLig As Long, i As Integer
Dim NO As Worksheet 'déclare la variable NO (Nouvel Onglet)

Application.ScreenUpdating = False
DerLig = Feuil2.Range("B" & Rows.Count).End(xlUp).Row
For i = 4 To DerLig
    On Error Resume Next 'gestion des erreurs (en cas d'erreur passe à la ligne suivante)
    Set NO = Worksheets(Feuil2.Cells(i, 2).Value) 'définit le nouvel onglet NO (génère une erreur su cet onglet n'existe pas)
    If Err <> 0 Then 'condition : si une erreur a été générée
        Sheets("Modèle").Copy After:=Sheets(Sheets.Count) 'copy l'onglet modèle en dernière position
        ActiveSheet.Name = Feuil2.Cells(i, 2) 'renomme l'onglet actif
        Set NO = ActiveSheet 'définit le nouvel onglet NO
    End If 'fin de la condition
    NO.Range("D5") = Feuil2.Cells(i, 2)
    NO.Range("H5") = Feuil2.Cells(i, 3)
    NO.Range("D6") = Feuil2.Cells(i, 4)
    NO.Range("A8") = Feuil2.Cells(i, 5)
    NO.Range("C8") = Feuil2.Cells(i, 6)
    NO.Range("F8") = Feuil2.Cells(i, 7)
    NO.Shapes.Range(Array("Picture_" & i - 3)).Delete
    If Err <> 0 Then Err = 0
    Feuil2.Activate
    Feuil2.Shapes.Range(Array("Picture_" & i - 3)).Select 'sélectionne l'image correspondante (génère une erreur si l'image n'existe pas)
    If Err <> 0 Then GoTo suite 'si une erreur a été générée, va à l'étiquette "suite"
    Selection.Copy
    NO.Activate
    NO.Range("A10").Select
    NO.Paste
    Selection.ShapeRange.IncrementLeft 260
    Selection.ShapeRange.IncrementTop 24
suite: 'étiquette
    NO.Range("A1").Select
    On Error GoTo 0 'annule la gestion des erreurs
Next i
Application.ScreenUpdating = True
End Sub
Rechercher des sujets similaires à "creer feuilles partir liste"