Macro recopier une feuille contenant des liens hypertexts en renomant les onglets

[christophe900]

Bonjour,

Sur le fichier joint, deux macros.

La première recopie la feuille 2 le nombre que fois que je veux, en conservant les liens hypertexts. (TRES IMPORTANT)
La deuxième creer des feuilles en renomant les onglets avec des noms dans une liste.

Je voudrais au finale faire du deux en un. une macro qui recopie la feuille "feuil1" autant de fois qu'il y a de nom dans la colonne nom de la feuille "liste th", en renomant les onglets avec le nom des personnes. TOUT EN CONCERVANT LES LIENS HYPERTEXT DE LA FEUILLE 1.

D'avance merci

 

[juju_69]

Re : Macro recopier une feuille contenant des liens hypertexts en renomant les onglet

Bonjour,

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

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

@ +

Juju

 

[christophe900]

Re : Macro recopier une feuille contenant des liens hypertexts en renomant les onglet

un grand merci.... faut vraiment que je prenne des cours de vba!!!!