Bonjour,

J'ai sur mon fichier une feuille nommé "Base" avec une liste de nom de pays en colonne "A4" et j'ai code qui me permet de créer des onglets en fonction de cette liste et j'ai un onglet qui se nomme "Modele"
Ma recherche et un code pour me copier ma feuille nommé "Modele"et le coller a l'identique sur les feuille créer.

Mon code
Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
Option Explicit
 
Sub CreationLiens()
 
Dim curCell As Range
Set curCell = ThisWorkbook.Sheets("Base").Range("A4")
While curCell.Value <> vbNullString
   ' ThisWorkbook.Sheets.Add After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
   ThisWorkbook.Sheets("modele").Copy After:=Sheets(ThisWorkbook.Sheets.Count) 
 ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name = curCell.Value & " " & curCell.Offset(0, 1).Value
    ThisWorkbook.Sheets("Base").Hyperlinks.Add Anchor:=curCell.Offset(0, 2), Address:="", SubAddress:= _
        "'" & ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name & "'!A4", TextToDisplay:="Acces Feuille"
    Set curCell = curCell.Offset(1, 0)
 
  'Supprimer quadrillage
 ActiveWindow.DisplayGridlines = False
   'Stop
 
Wend
'STOP
 
 'Récuperer le nom de l'onglet
 Dim f As Worksheet
     For Each f In Worksheets
     If f.Name <> "Base" Then
     f.Range("K1") = f.Name
 
         With f.Range("k1")
            ' .Borders.Weight = 3
             .Font.Bold = True
             .Font.Size = 18
             .Font.Italic = True
             .Font.Name = "Calibri"
         End With
         End If
     Next
'STOP
 
'Ajouter lien vers feuille Acceuil et suivant / précédent
Dim i As Integer
 
  For i = 2 To Sheets.Count
    Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Range("A1"), Address:="", _
          SubAddress:="'" & Sheets(1).Name & "'!A1", TextToDisplay:="Retour"
 
  Next i
'******* STOP
 
'Créer un lien Suivant et Précedent
     For i = 1 To Sheets.Count
         If i < Sheets.Count Then Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Range("B1"), Address:="", _
                                  SubAddress:="'" & Sheets(i + 1).Name & "'!B1", TextToDisplay:="Suivante"
         If i > 1 Then Sheets(i).Hyperlinks.Add Anchor:=Sheets(i).Range("C1"), Address:="", _
                                  SubAddress:="'" & Sheets(i - 1).Name & "'!C1", TextToDisplay:="Précédente"
     Next i
'******* STOP
 
Sheets("Base").Activate
End Sub
 
'Supprimer Onglet sauf les deux premiere feuille
Sub suppFeuilles()
 
     Dim ws As Worksheet
     For Each ws In Worksheets
         Application.DisplayAlerts = False
         If ws.Name <> "Base" And ws.Name <> "Modele" Then ws.Delete
     Next
 
     'Supprimer la collone (3) lien vers onglet
     ThisWorkbook.Sheets("Base").Columns(3).ClearContents
 
     Application.DisplayAlerts = True
 
     'Effacer la cellule B1
     Range("B1").Clear
 
End Sub
Je vous remercie de votre aide

Cordialement

Max