liens hypertext ne fonctionne pas

Bonjour, Juju m'a aider hier pour une concaténation de deux macro, qui aurai du à la fin, me permettre de créer, suivant une liste de nom, une nouvelle feuille avec inscrit "le nom" sur l'onglet, ceci fonctionne à merveille, cependant, les liens hypertexts ne fontionne pas, ils converges tous vers une même feuille "feuil1(2)", ni connaissant absolument rien, est il possible de faire quelques choses?

D'avance merci.


Voici le code modifié :
Sub to_test() ' dans colonne b7:b que nouvelles feuilles ajoutées avec nom repris des cellules B:B

Dim plage As Range
Dim cn As Range
Dim n As Long
Dim MonNom As String

Application.ScreenUpdating = False

Sheets("liste th").Activate
n = Sheets.Count
Set plage = Range("B7:B" & Range("B65536").End(xlUp).Row)
For Each cn In plage
If cn <> "0" And cn <> "" Then
MonNom = IIf(Len(cn.Value) > 32, Left(cn.Value, 31), cn.Value)
On Error Resume Next
Sheets("Feuil1").Copy After:=Sheets(Sheets.Count) 'on copie la feuille 1, copie qu'on place en fin

For i = 1 To ActiveSheet.Hyperlinks.Count 'de 1 jusqu'au nombre de liens hypertexte dans la feuille
x = InStr(1, ActiveSheet.Hyperlinks(i).SubAddress, "!") 'on calcule la position du ! dans le lien
y = Right(ActiveSheet.Hyperlinks(i).SubAddress, Len(ActiveSheet.Hyperlinks(i).SubAddress) - x)
ActiveSheet.Hyperlinks(i).SubAddress = "'" & ActiveSheet.Name & "'" & "!" & y
Next i

ActiveSheet.Name = MonNom
End If
Next cn

End Sub