Peut on créer un lien hypertexte renvoyant à un signet de Word de la même suite ?

[anthoYS]

Bonjour,


Voilà j'ai plusieurs signets sur un Word, mais il faut que je clique sur "atteindre" pour y aller, or j'ai tout le temps un classeur Excel et Word. Et je travaille sur les deux. Du coup, ça ne me convient pas, de cliquer sur "signet" (raccourci créer dans le ruban de Word) puis "atteindre" car y'a un risque de cliquer sur "ajouter" ou "supprimer" par inadvertance...

d'où ma question, savoir d'y accéder directement à partir d'Excel. je veux dire, qu'Excel me renvoie au signet voulu, je créer par exemple la liste de tous les signets, dans chaque cellule, en colonne, puis voilà.


Merci de me dire, si vous savez.

 

[anthoYS]

UP

(parmi les 18 qui ont vus, personne n'a idée ?)

 

[job75]

Bonsoir anthoYS,

Voyez les fichiers zippés joints et cette macro dans le fichier Excel :

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Target.Row = 1 Or Target = "" Then Exit Sub
Cancel = True
ThisWorkbook.FollowHyperlink ThisWorkbook.Path & "\" & Cells(Target.Row, 1)
If Target.Column > 1 Then GetObject(, "Word.Application").Selection.GoTo What:=-1, Name:=Target '-1 pour wdGoToBookmark
End Sub

A+

 

[anthoYS]

Merci job75. ça ne marche pas chez moi, ce n'est pas grave, je laisse tomber, j'y reviendrais peut être plus tard...

 

[job75]

Re,

Vous avez bien fait l'extraction des 2 fichiers dans un même dossier (le bureau) ?

Car il s'agit d'un code élémentaire qui doit fonctionner sous toutes versions.

A+

 

[anthoYS]

Ah ok, j'ai ouvert les deux fichiers à partir de l'archive pensant que ça suffirait, ok merci pour la précision

 

[job75]

Re,

J'avais écrit Target(1, 2 - Target.Column) mais Cells(Target.Row, 1) est quand même plus compréhensible...

A+

 

[job75]

Bonjour anthoYs, le forum,

Au lieu d'utiliser le double-clic on peut créer des liens hypertextes :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim chemin$, r As Range, c As Range
chemin = ThisWorkbook.Path & "\" 'adapter au besoin
Set r = Intersect(Target.EntireRow, Me.UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r.Rows
  r.Hyperlinks.Delete 'RAZ
  If CStr(Cells(r.Row, 1)) <> "" And Dir(chemin & CStr(Cells(r.Row, 1))) <> "" Then
    For Each c In r.SpecialCells(xlCellTypeConstants)
      c.Hyperlinks.Add c, chemin & Cells(r.Row, 1) 'création du lien hypertexte
    Next c
  End If
Next r
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal h As Hyperlink)
If h.Parent.Column = 1 Then Exit Sub
On Error Resume Next
With GetObject(, "Word.Application").Selection
  If IsError(.Document.Bookmarks(h.Parent)) Then h.Delete 'si le signet n'existe pas
  .GoTo What:=-1, Name:=h.Parent '-1 pour wdGoToBookmark
End With
End Sub

Aucun bug possible, même si le signet n'existe pas.

Fichier (2).

Bonne journée.

 

[anthoYS]

Bonjour @job75

oui c'est mieux ça (pour moi ça colle plus à ma demande), merci !

De même.

 

[job75]

Re,

S'il peut y avoir des formules dans la feuille utiliser :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim chemin$, r As Range, c As Range
chemin = ThisWorkbook.Path & "\" 'adapter au besoin
Set r = Intersect(Target.EntireRow, Me.UsedRange)
If r Is Nothing Then Exit Sub
For Each r In r.Rows 'si entrées multiples (copier-coller)
  r.Hyperlinks.Delete 'RAZ
  If CStr(Cells(r.Row, 1)) <> "" And Dir(chemin & CStr(Cells(r.Row, 1))) <> "" Then
    For Each c In Intersect(r, Me.UsedRange)
      If CStr(c) <> "" Then c.Hyperlinks.Add c, chemin & Cells(r.Row, 1) 'création du lien hypertexte
    Next c
  End If
Next r
End Sub

Private Sub Worksheet_FollowHyperlink(ByVal h As Hyperlink)
If h.Parent.Column = 1 Then Exit Sub
On Error Resume Next
With GetObject(, "Word.Application").Selection
  If IsError(.Document.Bookmarks(h.Parent)) Then h.Delete 'si le signet n'existe pas
  .GoTo What:=-1, Name:=h.Parent '-1 pour wdGoToBookmark
End With
End Sub

Fichier (3).

A+

 

[job75]

Re,

Pour tester j'ai copié-collé la ligne 4 (3 signets) sur 1000 lignes.

Sur Win 10 - Excel 2013 l'opération - exécution de la Worksheet_Change - prend :

- 3,2 secondes avec le fichier (2)

- 2,4 secondes avec le fichier (3).

C'est donc assez rapide, utilisez la version (3), plus générale.

A+