Création d'onglets avec lien hypertexte

Bonjour à toutes et tous,

J'ai créé un classeur permettant de créer des onglets d'après une liste de noms. La macro crée bien les onglets après avoir vérifié qu'ils n'existent pas déjà.
Je souhaiterai avoir un lien hypertexte automatique vers chaque nouvel onglet dans ma feuille initiale dans la cellule adjacente à chaque nom. Ma macro crée bien les liens hypertextes mais les copie tous dans la même cellule en effaçant le lien précédemment créé.

Voici le code de la macro :

Sub AjouteFeuilles()
Dim J As Long
Dim Ws As Worksheet
Set curCell = ThisWorkbook.Sheets("Stagiaires").Range("c3")
Set Stagiaires = Sheets("Stagiaires")
Stagiaires.[c2].CurrentRegion.Sort Key1:=Stagiaires.Range("c3"), Order1:=xlAscending, Header:=xlGuess
ligStagiaires = 2

Application.ScreenUpdating = False
Set Ws = ActiveSheet

For J = 3 To Ws.Range("C" & Rows.Count).End(xlUp).Row
If Not FeuilleExiste(Ws.Range("C" & J).Value & " " & Ws.Range("D" & J).Value) Then
Sheets("Frais").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = Ws.Range("C" & J) & " " & Ws.Range("D" & J)

Sheets("Stagiaires").Hyperlinks.Add Anchor:=curCell.Offset(0, -1), Address:="", SubAddress:= _
"'" & ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count).Name & "'!b3", TextToDisplay:="Acces Feuille"
End If

Next J

Ws.Select

Set curCell = curCell.Offset(1, 0)

End Sub

Function FeuilleExiste(Nom As String) As Boolean
On Error Resume Next
FeuilleExiste = Sheets(Nom).Name <> ""
On Error GoTo 0
End Function


Je vous remercie pour l'aide que vous pourrez m'apporter.