Créations 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).Nam e & "'!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.

Bonjour

Macro modifiée

Elle refera les liens même si les pages existent

Sub AjouteFeuilles()
Dim J As Long
Dim Ws As Worksheet
Dim NomFeuille As String

  Application.ScreenUpdating = False

  Set Ws = ActiveSheet

  [c2].CurrentRegion.Sort Key1:=Range("c3"), Order1:=xlAscending, Header:=xlGuess

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

    Ws.Hyperlinks.Add Anchor:=Ws.Range("B" & J), Address:="", SubAddress:= _
        "'" & NomFeuille & "'!b3", TextToDisplay:="Acces Feuille"

  Next J

  Ws.Select
End Sub

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

Merci beaucoup Banzai64 pour ton aide rapide et très efficace.

Cela fonctionne à merveille.

Bien à vous.

à Banzaï64

Bonjour,

Cette création d'onglets avec liens hypertextes est parfaite mais peut-on reporter en même temps le nom et prénom pour compléter la fiche sans être obligé de les ressaisir.

Je suis débutant en matière de macro et là je suis bloqué.

Un grand merci pour ce coup de main.

Cordialement,

Banzai64 a écrit :

Bonjour

Macro modifiée

Elle refera les liens même si les pages existent

Sub AjouteFeuilles()
Dim J As Long
Dim Ws As Worksheet
Dim NomFeuille As String

  Application.ScreenUpdating = False

  Set Ws = ActiveSheet

  [c2].CurrentRegion.Sort Key1:=Range("c3"), Order1:=xlAscending, Header:=xlGuess

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

    Ws.Hyperlinks.Add Anchor:=Ws.Range("B" & J), Address:="", SubAddress:= _
        "'" & NomFeuille & "'!b3", TextToDisplay:="Acces Feuille"

  Next J

  Ws.Select
End Sub

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