XL 2019 Lien hypertexte

[Tarrain]

Bonjour,

J'ai fait un planning avec des liens hypertexte pour aller plus vite dans ma feuille, par contre j'ai une feuille par semaine et quand je fais copier une feuille dans un nouvel onglet pour une nouvelle semaine, mes liens hypertextes de la nouvelle feuille vont toujours vers l'ancienne feuille copiée ! ! rrrr
A moins de les faire un a un pour les 53 feuilles, j'aurai aimé savoir si quelqu'un pourrait me faire SVP un bouton macro que je mettrai sur chaque feuille pour modifier en rapide le nom de ma feuille .

Vous pouvez voir mon souci dans mon fichier ou j'ai copié la feuille 3 en 4
voici le lien de mon fichier : https://send.firefox.com/download/439b8731cc9d51f5/#Dkj8J7K8AB01hoDYrC3nKQ

Merci à chacun pour votre investissement dans mon projet

SEB

 

[sylvanu]

Bonjour Tarrain,
Est ce que toutes vos images renvoient vers même feuille cellule A1 ?
Comme cela semble être le cas.
En d'autres termes : Faut-il accrocher un lien hypertexte qui pointe sur A1 sur chaque image de la feuille ?

 

[Tarrain]

Bonjour,

Non chaque image ou texte ayant un lien hypertexte renvoie chacune vers une cellule différente.
Ce qu'il faudrait pour bien faire c'est une macro avec un bouton sur chaque nouvelle feuille qui modifiérait pour la feuille concernée le nom de l'onglet pour tous les liens hypertexte

Exemple : onglet 4 en fgh6 en survolent la cellule on un a un lien hypertexte '3'! CO140
Il faudrait donc modifier '3'! par '4'! en masse pour tous les liens hypertxtes et aisni de suite pour les 53 onglets
Cela pourrait se faire manuellement si quand on clic sur un bouton s'ouvre une fenetre avec '3'! qu'il faudrait modifier dans un cadre par '4'!

Merci beaucoup

 

[sylvanu]

Bonsoir Tarrain,
Essayez cette PJ.
On lance par ALT+F8 ChangeHyperlinks
J'ai mis dans le StatusBar le nombre de liens modifiés.

Si vous transférer la macro dans votre fichier original, je conseille fortement de faire une copie avant car ne sachant pas où les liens pointés, je fais des modifs à l’aveugle. même si j'ai testé sur un fichier perso beaucoup plus simple.

La macro très courte est la suivante :

Sub ChangeHyperlinks()
Dim ws As Worksheet, N As Integer
For Each ws In Worksheets
    ws.Activate
    For Each h In ActiveSheet.Hyperlinks
        N = N + 1
        Application.StatusBar = "Hyperlinks changed : " & N
        'On trouve l'emplacement du !
        PointExclam = InStr(1, h.SubAddress, "!", vbTextCompare)
        AncienNom = Mid(h.SubAddress, 1, PointExclam)
        'On remplace par le nom de la feuille actuelle
        h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")
    Next
Next
Application.StatusBar = ""
End Sub

Bonne chance.

https://www.cjoint.com/c/JBDrRqsFP1Y

 

[Tarrain]

Bonjour,

Merci pour votre test, je sens que l'on va y arriver!!!
Je viens de tester sur l'onglet 4 , j'ai une erreur d'execution "1004" et dans le statubar j'ai hyperlinks changed : 150 et mon surseur se retrouve sur l'onglet 1 actif ?

Quand je fais débogage j'ai :

Sub ChangeHyperlinks()
Dim ws As Worksheet, N As Integer
For Each ws In Worksheets
ws.Activate
For Each h In ActiveSheet.Hyperlinks
N = N + 1
Application.StatusBar = "Hyperlinks changed : " & N
'On trouve l'emplacement du !
PointExclam = InStr(1, h.SubAddress, "!", vbTextCompare)
AncienNom = Mid(h.SubAddress, 1, PointExclam)
'On remplace par le nom de la feuille actuelle

AVEC CETTE LIGNE SURLIGNEE en jaune --->
h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")

Next
Next
Application.StatusBar = ""
End Sub

MERCI pour ton aide , je sens que tu n'es pas loin de la super solution !

 

[sylvanu]

Re,
Je vais avoir du mal à cerner le problème ici.
Sur le fichier que vous avais envoyé, ça marche chez moi.
Ca se termine à 674 modifications pour les 4 pages.

Lors de l'erreur, regardez ce que vaut AncienNom et ws.Name en survolant avec la souris ces deux variables, un popup devrait apparaître avec les valeurs.

Essayez avec cette syntaxe :

h.SubAddress = Replace(h.SubAddress, AncienNom, "'" & ws.Name & "'" & "!")

Pour être conforme à votre notation d'origine.
( je suis sous 2007, peut être une différence avec 2019 )

 

[Tarrain]

Je vais regarder , mais je ne suis pas un bon en macro

Je me pose une question ?

Vous me dites que cela fais 674 modifications ?
que je comprenne bien cela fait la modif pour tous les onglets ? en reprenant pour tous les onglets le nom de l'onglet, c'est cela ?

Merci encore a vous

 

[Tarrain]

Je viens de regarder en survolant AncienNom et ws.Name et j'ai pour AncienNom "'1'!" et pour ws.Name : "1"

 

[sylvanu]

Re,
Oui j'ai trouvé 674 liens hypertexte dans votre fichier. Soit u peu plus de 160 par feuille.

Si les erreurs continuent, essayez cela.
Je compte les erreurs et les ignorent quand elles apparaissent.
( évidemment je n'ai pas testé car je n'ai aucune erreur, et je n'arrive pas à trouver un lien qui poserai problème.)
Pensez aussi à supprimer les mot de passe sur deux ou trois onglets.

Sub ChangeHyperlinks()
Dim ws As Worksheet, N As Integer, NbError
NbError = 0
For Each ws In Worksheets
    ws.Activate
    For Each h In ActiveSheet.Hyperlinks
        N = N + 1
        'On trouve l'emplacement du !
        PointExclam = InStr(1, h.SubAddress, "!", vbTextCompare)
        AncienNom = Mid(h.SubAddress, 1, PointExclam)
        'On remplace par le nom de la feuille actuelle
        If IsError(h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")) = True Then
            NbError = NbError + 1
        Else
            h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")
        End If
        Application.StatusBar = "NbError = " & NbError & "  -  Hyperlinks changed : " & N
    Next
Next
'Application.StatusBar = ""
End Sub

 

[sylvanu]

Je viens de regarder en survolant AncienNom et ws.Name et j'ai pour AncienNom "'1'!" et pour ws.Name : "1"

Je viens de regarder avec un point d’arrêt. J'ai la même chose :

Ce qui est une config normale. Chez moi elle ne provoque aucune erreur.

essayez la macro qui gère les erreurs, on va peut être avancer.

 

[sylvanu]

Si les erreurs persistent, prenez ce module :

Sub ChangeHyperlinks()
On Error GoTo Fin:
Dim ws As Worksheet, N As Integer, NbError
NbError = 0
For Each ws In Worksheets
    ws.Activate
    For Each h In ActiveSheet.Hyperlinks
        N = N + 1
        'On trouve l'emplacement du !
        PointExclam = InStr(1, h.SubAddress, "!", vbTextCompare)
        AncienNom = Mid(h.SubAddress, 1, PointExclam)
        'On remplace par le nom de la feuille actuelle
        If IsError(h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")) = True Then
            NbError = NbError + 1
        Else
            h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")
        End If
        Application.StatusBar = "NbError = " & NbError & "  -  Hyperlinks changed : " & N
    Next
Next
'Application.StatusBar = ""
Exit Sub
Fin:
MsgBox ("Nombre de liens trouvés : " & N & vbCrLf & _
        "Nom de la feuille : " & ws.Name & vbCrLf & _
        "Ancien nom :  " & AncienNom & vbCrLf & _
        "Contenu du lien : " & h.SubAddress & vbCrLf & _
        "Position du ! :  " & PointExclam & vbCrLf & _
        "Nouveau nom :  " & Replace(h.SubAddress, AncienNom, ws.Name & "!") & vbCrLf)
End Sub

En cas d'erreur j’arrête tout et dans un MsgBox je donne toutes les variables.

 

[sylvanu]

Bonjour de bon matin,
J'ai regardé de tous coté et ne voit aucune raison d'avoir cette erreur.
Donc si pas de solution trouvée, testez le module ci joint.
Je crée une feuille Log en premier et y enregistre toutes les données à chaque fois qu'une erreur se produit. On aura ainsi des données à analyser pour comprendre l'erreur.

Sub ChangeHyperlinks()
On Error Resume Next
Dim ws As Worksheet, N As Integer, NbError, indexLog
CreerFeuilleLog
NbError = 0
indexLog = 2
For Each ws In Worksheets
    ws.Activate
    For Each h In ActiveSheet.Hyperlinks
        N = N + 1
        'On trouve l'emplacement du !
        PointExclam = InStr(1, h.SubAddress, "!", vbTextCompare)
        AncienNom = Mid(h.SubAddress, 1, PointExclam)
        'On remplace par le nom de la feuille actuelle
        If Err > 0 Then ' si erreur remplit la feuille Log
            NbError = NbError + 1
            Sheets("Log").Cells(indexLog, 1) = ws.Name
            Sheets("Log").Cells(indexLog, 2) = h.SubAddress
            Sheets("Log").Cells(indexLog, 3) = AncienNom
            Sheets("Log").Cells(indexLog, 4) = PointExclam
            Sheets("Log").Cells(indexLog, 5) = Replace(h.SubAddress, AncienNom, ws.Name & "!")
            Sheets("Log").Cells(indexLog, 6) = NbError
            Sheets("Log").Cells(indexLog, 7) = N
            Sheets("Log").Cells(indexLog, 8) = Err.Number
            Err.Clear
            indexLog = indexLog + 1
        Else
            h.SubAddress = Replace(h.SubAddress, AncienNom, ws.Name & "!")
        End If
        Application.StatusBar = "NbError = " & NbError & "  -  Hyperlinks changed : " & N
    Next
Next
'Application.StatusBar = ""
End Sub
Sub CreerFeuilleLog()
On Error GoTo SiErreur
Dim Feuille As Worksheet
    FeuilleExiste = False
    For Each Feuille In Worksheets
        If Feuille.Name = "Log" Then
            FeuilleExiste = True
        End If
    Next Feuille
    If FeuilleExiste = False Then
        Sheets.Add(Before:=Sheets("LISTES")).Name = "Log"
    End If
    initlog
Exit Sub
SiErreur:
MsgBox "ERREUR"
End Sub
Sub initlog()
    Sheets("Log").Select
    Cells.Select
    Selection.ClearContents
    Range("A1").Select
    Sheets("Log").Cells(1, 1) = "ws.Name"
    Sheets("Log").Cells(1, 2) = "h.SubAddress"
    Sheets("Log").Cells(1, 3) = "AncienNom"
    Sheets("Log").Cells(1, 4) = "PointExclam"
    Sheets("Log").Cells(1, 5) = "Replace"
    Sheets("Log").Cells(1, 6) = "NbError"
    Sheets("Log").Cells(1, 7) = "No links"
    Sheets("Log").Cells(1, 8) = "No d'erreur"
End Sub

Ou plus simple : https://www.cjoint.com/c/JCbheXIJn1Y
Dans ce fichier je n'ai strictement aucune erreur. Et vous ?

 

[mapomme]

Bonjour @Tarrain, @sylvanu ,

On peut utiliser une méthode simple sans VBA pour indiquer que l'adresse du lien est sur la feuille courante. On peut donc ainsi copier ou dupliquer la feuille sans problème.

On utilise la formule =LIEN_HYPERTEXTE() combiné avec le signe dièse #.

exemple : =LIEN_HYPERTEXTE("#H3";"Vers H3 de cette feuille")
Si on duplique la feuille ou copie cette cellule sur autre feuille, alors on pointera toujours vers la cellule H3 de la feuille où se trouve la cellule avec cette formule.

nota: votre fichier semble comporter des noms et prénoms de personnes existantes. Si c'est le cas, cela est contraire au RGPD et à la charte du forum. Si c'est avéré, il faut remplacer votre fichier par un fichier anonymisé.

 

[sylvanu]

Bonjour MaPomme,
Le problème est que Tarrain a un fichier de 62 feuilles avec plus de 100 liens par page.
Et qu'il s'est aperçu à la fin que des liens pointaient mal. C'est ballot.
D'où l'idée d'une macro pour tout remettre carré en un one shot.
Le pb c'est que ma macro marche très bien chez moi ( XL2007 ) et plante chez Tarrain ( XL2019 )
D'où les différents codes qui traînent sur le fil avec un log pour essayer de comprendre.

 

[mapomme]

Re @sylvanu

Le problème est que Tarrain a un fichier de 62 feuilles avec plus de 100 liens par page.

Ok! Ok!