Copier des feuilles selon modele

P

PC1.FORUM

XLDnaute Nouveau
Bonsoir à tous,
Je vous contacte pour m’aider à finir mon projet.
Dans un classeur j’ai une feuille « liste », ainsi qu’une feuille « modele »
Mon projet :
Créer une commande qui me permet de fabriquer autant de feuilles que de noms saisis dans mon tableau qui est dans « liste » et nommer ces feuilles au nom trouvé dans le tableau.
Jusque là j’ai réussi !
• Le problème que je rencontre est que le modèle copié (renommé au nom) doit en B1 et B2 reprendre certaines données du tableau (liste).
• Dans liste, je ne sais pas lors de la copie du modèle faire en colonne A de liste le lien au nom de la feuille créée
• Et enfin lors de la saisie dans les nouvelles feuilles créée de compléter au fur et à mesure le tableau récapitulatif dans liste (ville1 et Ville2)
Merci pour votre aide.
Ci joint un fichier exemple.
Code: 
Sub Creation_feuille()
Dim i, z, y
'lecture du nombre de NOM donc du nombre de feuilles à créer
z = ActiveSheet.Range("B1").Value

For i = 1 To z
'lecture du nom
y = Sheets("LISTE").Cells(i + 2, 2).Value
'z copies de la feuille MODELE
    Sheets("MODELE").Copy After:=Sheets(i)
    'nommage au nom  y
    ActiveSheet.Name = y
Next i
End Sub
 

Pièces jointes

  • essai1.xls
    43 KB · Affichages: 55
  • essai1.xls
    43 KB · Affichages: 55
  • essai1.xls
    43 KB · Affichages: 49
Trier par date Trier par votes
K

kjin

XLDnaute Barbatruc
Re : Copier des feuilles selon modele

bonsoir,
Code: 
Sub Creation_feuille()
Dim i%, nom$, prenom$, nf$, sAdress
Application.ScreenUpdating = False
With ActiveSheet
    For i = 3 To .[B1] + 2
        nom = .Cells(i, 2)
        prenom = .Cells(i, 3)
        nf = nom & "_" & Left(prenom, 1)
        Sheets("MODELE").Copy After:=Sheets(Sheets.Count)
        With ActiveSheet
            .Name = nf
            .Cells(1, 2) = nom
            .Cells(2, 2) = prenom
        End With
        sAdress = nf & "!A1"
        .Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", SubAddress:=sAdress
        .Cells(i, 4).Formula = "=IF(" & nf & "!A5="""",""""," & nf & "!A5)"
        .Cells(i, 5).Formula = "=IF(" & nf & "!B5="""",""""," & nf & "!B5)"
        .Activate
    Next
End With
End Sub
kjin
 
Vote positif 0 Vote négatif
Isab

Isab

XLDnaute Occasionnel
Re : Copier des feuilles selon modele

Bonsoir


Juste en complement ...

Ne pas executer la macro plus d'une fois.. sinon bug
autrement , prévoir vérification de l'existance des feuilles avant création.

Isab/....
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Copier des feuilles selon modele

Bonjour à tous.


Une autre proposition :​
VB: 
Sub Creation_feuille()
Dim i&, j&, y$, z&
  With Sheets("LISTE") '
    z = .Range("B1").Value 'Nombre de feuilles à créer.
    If z > 0 Then '
      j = 2 'Index de positionnement des feuilles créées.
      Do '
        With .[B3].Offset(i) 'Parcourt la liste de noms.
          y = CStr(.Value) '
          If y <> "" Then 'Si un nom est trouvé...
            Sheets("modèle").Copy After:=Sheets(j) '...créer une nouvelle feuille...
            On Error Resume Next '
            ActiveSheet.Name = y '...et tenter de la nommer.
            If Err.Number = 1004 Then 'Si une feuille du même nom existe, ou si le nom est incorrect : erreur !
              Application.DisplayAlerts = False '
              ActiveSheet.Delete 'Suppression de la feuille créée.
              Application.DisplayAlerts = True '
              Err.Clear '
              On Error GoTo E '
              Sheets(y).Activate 'Le cas échéant, activation de la feuille existante...
            Else '
              j = j + 1 'Incrémente l'index de positionnement des feuilles.
            End If '
            On Error GoTo 0 '
'=== Mise à jour des données de la feuille active :
            ActiveSheet.Range("B1:B2").Value = WorksheetFunction.Transpose(.Resize(1, 2).Value) 'Nom, prénom
            ActiveSheet.Range("A5:B5").Value = .Offset(, 2).Resize(1, 2).Value 'Villes
'==========================================
'=== Liaison de la feuille à la liste :
            .Parent.Hyperlinks.Add Anchor:=.Offset(, -1).Cells, Address:="", SubAddress:=y & "!A1" '
'=====================================
R:          z = z - 1 'Décrémente le nombre de feuilles à créer.
          End If '
          i = i + 1 'Incrémente l'index de parcours de la liste de noms.
        End With '
      Loop While z 'Si z=0, terminé !
    End If '
  End With '
Exit Sub
E:
  MsgBox y & " n'est pas un nom correct pour une feuille." '
  On Error GoTo 0 '
  Resume R '
End Sub


Bonne nuit.


ℝOGER2327
#7095

Samedi 7 Décervelage 141 (Saints Forçats, pollorcètes - fête Suprême Quarte)
15 Nivôse An CCXXII, 0,8164h - lapin
2014-W01-6T01:57:34Z


P.s. : Voir le code corrigé au message #12.
 

Pièces jointes

  • essai1.xls
    51 KB · Affichages: 53
  • essai1.xls
    51 KB · Affichages: 55
  • essai1.xls
    51 KB · Affichages: 61
Dernière édition:
Vote positif 0 Vote négatif
Isab

Isab

XLDnaute Occasionnel
Re : Copier des feuilles selon modele

Bonsoir


En effet ...j'ai vu... mais mon message était avant de voir votre code..
peut-être un dialogue avant le :

Application.DisplayAlerts = False
L'utilisateur choisira d'écraser les feuilles par les nouvelles ou de conserver les anciennes.

Bonne année

Isab/....
 
Dernière édition:
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Copier des feuilles selon modele

Re...


Isab à dit:
Bonsoir


En effet ...j'ai vu... mais mon message était avant de voir votre code..
peut-être un dialogue avant le :

Application.DisplayAlerts = False
L'utilisateur choisira d'écraser les feuilles par les nouvelles ou de conserver les anciennes.

Bonne année

Isab/....
Cliquez pour agrandir...
Oui, on verra ce qu'il en pense : soit la mise à jour (que j'ai choisie en l'absence de cahier des charges précis), soit la conservation sans mise à jour. Ma boule de cristal n'a pas su me dire ce que souhaite notre ami...​


Bonne année à vous aussi.


ℝOGER2327
#7097

Samedi 7 Décervelage 141 (Saints Forçats, pollorcètes - fête Suprême Quarte)
15 Nivôse An CCXXII, 1,1376h - lapin
2014-W01-6T02:43:49Z
 
Vote positif 0 Vote négatif
P

PC1.FORUM

XLDnaute Nouveau
Re : Copier des feuilles selon modele

Bonjour à tous,
Quelle célérité!! Que je pense qu'il m'a fallu un temps certain pour réussir "avec fierté" à produire mon petit bout de code.

Il ne me reste plus qu'a l'adapter (j'espère que je serai à la hauteur). Le modèle sera un QCM et le résultat (notes) sera reporté sur mon tableau. Je vous soumettrai nom travail.
Encore merci pour votre efficacité.
Bonne Année
 
Vote positif 0 Vote négatif
K

kjin

XLDnaute Barbatruc
Re : Copier des feuilles selon modele

Bonjour,
Les feuilles existantes sont conservées
Les feuilles sont nommées avec le nom et la première lettre du prénom
Code: 
Sub Creation_feuille()
Dim i%, nom$, prenom$, nf$, sAdress, ws As Worksheet
Application.ScreenUpdating = False
With ActiveSheet
    For i = 3 To .[B1] + 2
        nom = .Cells(i, 2)
        prenom = .Cells(i, 3)
        nf = nom & "_" & Left(prenom, 1)
        Set ws = Nothing
        On Error Resume Next
        Set ws = Sheets(nf)
        On Error GoTo 0
        If ws Is Nothing Then
            Sheets("MODELE").Copy After:=Sheets(Sheets.Count)
            With ActiveSheet
                .Name = nf
                .Cells(1, 2) = nom
                .Cells(2, 2) = prenom
            End With
            sAdress = nf & "!A1"
            .Hyperlinks.Add Anchor:=.Cells(i, 1), Address:="", SubAddress:=sAdress
            .Cells(i, 4).Formula = "=IF(" & nf & "!A5="""",""""," & nf & "!A5)"
            .Cells(i, 5).Formula = "=IF(" & nf & "!B5="""",""""," & nf & "!B5)"
        End If
    Next
    .Activate
End With
End Sub
kjin
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Copier des feuilles selon modele

Bonsoir à tous.


Quelques corrections du code d'hier (message #5) :​
VB: 
Sub Creation_feuille_1() 'Mise à jour des feuilles déjà existantes.
Dim i&, j&, y$, z&
  With Sheets("LISTE") '
    z = .Range("B1").Value 'Nombre de feuilles à créer.
    If z > 0 Then '
      j = 2 'Index de positionnement des feuilles créées.
      Do '
        With .[B3].Offset(i) 'Parcourt la liste de noms.
          y = CStr(.Value) '
          If y <> "" Then 'Si un nom est trouvé...
            y = Left$(y, 31) '
            If y Like "*['/:?\]*" Or y Like "*[*]*" Or y Like "*[[]*" Or y Like "*[]]*" Then '
              MsgBox y & " n'est pas un nom correct pour une feuille." '
            Else '
              On Error Resume Next '
              Sheets(y).Activate 'Le cas échéant, activation de la feuille existante.
              If Err.Number Then '
                Sheets("modèle").Copy After:=Sheets(j) '...créer une nouvelle feuille...
                ActiveSheet.Name = y '...et la nommer.
                j = j + 1 'Incrémente l'index de positionnement des feuilles.
              End If '
              On Error GoTo 0 '
'=== Mise à jour des données de la feuille active :
              ActiveSheet.Range("B1:B2").Value = WorksheetFunction.Transpose(.Resize(1, 2).Value) 'Nom, prénom
              ActiveSheet.Range("A5:B5").Value = .Offset(, 2).Resize(1, 2).Value 'Villes
'================================================
'=== Liaison de la feuille à la liste :
              .Parent.Hyperlinks.Add Anchor:=.Offset(, -1).Cells, Address:="", SubAddress:="'" & y & "'!A1" '
'====================================
            End If
            z = z - 1 'Décrémente le nombre de feuilles à créer.
          End If '
          i = i + 1 'Incrémente l'index de parcours de la liste de noms.
        End With '
      Loop While z 'Si z=0, terminé !
    End If '
  End With '
End Sub
Une variante :​
VB: 
Sub Creation_feuille_2() 'Pas de mise à jour des feuilles déjà existantes.
Dim i&, j&, y$, z&
  With Sheets("LISTE") '
    z = .Range("B1").Value 'Nombre de feuilles à créer.
    If z > 0 Then '
      j = 2 'Index de positionnement des feuilles créées.
      Do '
        With .[B3].Offset(i) 'Parcourt la liste de noms.
          y = CStr(.Value) '
          If y <> "" Then 'Si un nom est trouvé...
            y = Left$(y, 31) '
            If y Like "*['/:?\]*" Or y Like "*[*]*" Or y Like "*[[]*" Or y Like "*[]]*" Then '
              MsgBox y & " n'est pas un nom correct pour une feuille." '
            Else '
              On Error Resume Next '
              Sheets(y).Activate 'Le cas échéant, activation de la feuille existante.
              If Err.Number Then '
                Sheets("modèle").Copy After:=Sheets(j) '...créer une nouvelle feuille...
                ActiveSheet.Name = y '...et la nommer.
'=== Mise à jour des données de la feuille active :
                ActiveSheet.Range("B1:B2").Value = WorksheetFunction.Transpose(.Resize(1, 2).Value) 'Nom, prénom
                ActiveSheet.Range("A5:B5").Value = .Offset(, 2).Resize(1, 2).Value 'Villes
'================================================
'=== Liaison de la feuille à la liste :
                .Parent.Hyperlinks.Add Anchor:=.Offset(, -1).Cells, Address:="", SubAddress:="'" & y & "'!A1" '
'====================================
                j = j + 1 'Incrémente l'index de positionnement des feuilles.
              End If '
              On Error GoTo 0 '
            End If
            z = z - 1 'Décrémente le nombre de feuilles à créer.
          End If '
          i = i + 1 'Incrémente l'index de parcours de la liste de noms.
        End With '
      Loop While z 'Si z=0, terminé !
    End If '
  End With '
End Sub


Bonne nuit.


ℝOGER2327
#7098

Dimanche 8 Décervelage 141 (Saint Bordue, Capitaine - fête Suprême Tierce)
16 Nivôse An CCXXII, 0,3544h - silex
2014-W01-7T00:51:02Z
 
Vote positif 0 Vote négatif
ROGER2327

ROGER2327

XLDnaute Barbatruc
Re : Copier des feuilles selon modele

Suite...


Mes propositions précédentes ne sont pas correctes. Peut-être ceci est-il plus sérieux ?​
VB: 
Sub Creation_feuille_1() 'Mise à jour des feuilles déjà existantes.
Dim i&, j&, k&, y$, z&, f As Worksheet, g As Chart
  With Sheets("LISTE") '
    z = .Range("B1").Value 'Nombre de feuilles à créer.
    If z > 0 Then '
      j = 2 'Index de positionnement des feuilles créées.
      Do '
        With .[B3].Offset(i) 'Parcourt la liste de noms.
          y = CStr(.Value) '
          If y <> "" Then 'Si un nom est trouvé...
            y = Left$(y, 31) '
            If y Like "*['/:?\]*" Or y Like "*[*]*" Or y Like "*[[]*" Or y Like "*[]]*" Then '
              MsgBox """" & y & """ n'est pas un nom correct pour une feuille." '
            Else '
              On Error Resume Next '
              Set f = Sheets(y): Set g = Sheets(y) '
              On Error GoTo 0 '
              k = (f Is Nothing) + 2 * (g Is Nothing) '
              Set f = Nothing: Set g = Nothing '
              Select Case k '
              Case -1: MsgBox "Vous ne pouvez pas créer une feuille de calcul nommée """ & y & """ car il existe une feuille graphique portant ce nom." '
              Case -2: Worksheets(y).Activate 'Le cas échéant, activation de la feuille existante.
              Case -3 'Il faut...
                Sheets("modèle").Copy After:=Sheets(j) '...créer une nouvelle feuille...
                ActiveSheet.Name = y '...et la nommer.
                j = j + 1 'Incrémente l'index de positionnement des feuilles.
              End Select '
              If k < -1 Then '
'=== Mise à jour des données de la feuille active :
                ActiveSheet.Range("B1:B2").Value = WorksheetFunction.Transpose(.Resize(1, 2).Value) 'Nom, prénom
                ActiveSheet.Range("A5:B5").Value = .Offset(, 2).Resize(1, 2).Value 'Villes
'================================================
'=== Liaison de la feuille à la liste :
                .Parent.Hyperlinks.Add Anchor:=.Offset(, -1).Cells, Address:="", SubAddress:="'" & y & "'!A1" '
'====================================
              End If '
            End If '
            z = z - 1 'Décrémente le nombre de feuilles à créer.
          End If '
          i = i + 1 'Incrémente l'index de parcours de la liste de noms.
        End With '
      Loop While z 'Si z=0, terminé !
    End If '
  End With '
End Sub
Et la variante :​
VB: 
Sub Creation_feuille_2() 'Pas de mise à jour des feuilles déjà existantes.
Dim i&, j&, y$, z&, f As Worksheet, g As Chart
  With Sheets("LISTE") '
    z = .Range("B1").Value 'Nombre de feuilles à créer.
    If z > 0 Then '
      j = 2 'Index de positionnement des feuilles créées.
      Do '
        With .[B3].Offset(i) 'Parcourt la liste de noms.
          y = CStr(.Value) '
          If y <> "" Then 'Si un nom est trouvé...
            y = Left$(y, 31) '
            If y Like "*['/:?\]*" Or y Like "*[*]*" Or y Like "*[[]*" Or y Like "*[]]*" Then '
              MsgBox """" & y & """ n'est pas un nom correct pour une feuille." '
            Else '
              On Error Resume Next '
              Set f = Sheets(y): Set g = Sheets(y) '
              On Error GoTo 0 '
              Select Case (f Is Nothing) + 2 * (g Is Nothing) '
              Case -1: MsgBox "Vous ne pouvez pas créer une feuille de calcul nommée """ & y & """ car il existe une feuille graphique portant ce nom." '
              Case -3 'Il faut...
                Sheets("modèle").Copy After:=Sheets(j) '...créer une nouvelle feuille...
                ActiveSheet.Name = y '...et la nommer.
                j = j + 1 'Incrémente l'index de positionnement des feuilles.
'=== Mise à jour des données de la feuille active :
                ActiveSheet.Range("B1:B2").Value = WorksheetFunction.Transpose(.Resize(1, 2).Value) 'Nom, prénom
                ActiveSheet.Range("A5:B5").Value = .Offset(, 2).Resize(1, 2).Value 'Villes
'================================================
'=== Liaison de la feuille à la liste :
                .Parent.Hyperlinks.Add Anchor:=.Offset(, -1).Cells, Address:="", SubAddress:="'" & y & "'!A1" '
'====================================
              End Select '
              Set f = Nothing: Set g = Nothing '
            End If '
            z = z - 1 'Décrémente le nombre de feuilles à créer.
          End If '
          i = i + 1 'Incrémente l'index de parcours de la liste de noms.
        End With '
      Loop While z 'Si z=0, terminé !
    End If '
  End With '
End Sub


ℝOGER2327
#7100

Dimanche 8 Décervelage 141 (Saint Bordue, Capitaine - fête Suprême Tierce)
16 Nivôse An CCXXII, 5,7125h - silex
2014-W01-7T13:42:36Z
 
Vote positif 0 Vote négatif

Discussions similaires

chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Automatisation Copie Lignes Feuilles selon leurs nom
Réponses
10
Affichages
209
chaelie2015
chaelie2015
D
  • Résolu(e)
Autres Création classeurs de 3 feuilles avec une information à reporter.
Réponses
7
Affichages
276
dhyeres
D
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Protection automatique des nouvelles feuilles
Réponses
6
Affichages
136
Phil69970
Phil69970
litelsousa
  • Résolu(e)
Microsoft 365 Nom de feuille dans formule selon valeur cellule
Réponses
2
Affichages
292
litelsousa
litelsousa
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
63
Latias
L
C
  • Résolu(e)
XL 2019 Copier et renommer (en même temps) des feuilles à partir d'une liste de noms dans un colonne
Réponses
13
Affichages
585
Clemee61
C
O
  • Résolu(e)
Microsoft 365 envoi par mail de feuilles Excel dont les noms des feuilles sont les adresses d'envoi
Réponses
14
Affichages
297
patricktoulon
patricktoulon
B
  • Question
XL 2013 Comment trier les nom des feuilles et fusionner leur tableaux dans une une autre feuille ?
Réponses
10
Affichages
203
Compte Supprimé 979
C
chaelie2015
  • Résolu(e)
XL 2013 (RESOLU) Automatisation de la création de feuilles en fonction des données de la cellule U13 et une feuille type
Réponses
7
Affichages
243
chaelie2015
chaelie2015
A
  • Résolu(e)
XL 2016 Calculer l’occurrence d’un nom sur plusieurs feuilles
Réponses
14
Affichages
362
ACMadara
A

Membres actuellement en ligne

5 membres et 63 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 107
Messages
2 085 354
Membres
102 873
dernier inscrit
yayo