How to Create a Hyperlink from table to a title (heading2) in Word with VBA ( From a table ) and do the reverse

Question

I tried to write a VBA code to create a Hyperlink between specific cells from a table to a Heading2 (with the same name) in my wordDocument and after the opposite link to come back to the table. I wrote all code, it is working up to the hyperlink but it links to the summary and no to the title with the Style Heading2

See my code below `

`Sub Create_Hyperlink_between_tables_and_Titles()
    
    Dim tbl As Table
    Dim cel As Cell
    Dim txt As String
    Dim NameList As String
    
   ' Search only Tables and create a list of cells name
  For Each tbl In ActiveDocument.Range.Tables
    For Each cel In tbl.Range.Cells
        txt = cel.Range.Text
         ' Check if the Text is >6 characters to avoid empty cells
            If Len(cel.Range.Text) > 6 Then
             NameList = Mid(txt, 1, Len(txt) - 2)
                With ActiveDocument.Range.Find
                .ClearFormatting`
                .Forward = True
                .Wrap = wdFindContinue
                .Format = True
                .Style = "Heading 2"
                .Text = NameList
                .Execute
           
           ' Create hyperlink between cells and Title
                    If .Found = True Then
                    ActiveDocument.Hyperlinks.Add Anchor:=cel.Range, Address:="", _
                    SubAddress:=NameList & Heading2, ScreenTip:="", TextToDisplay:=NameList
                    End If
        
  
                End With
           End If
    Next cel
  Next tbl  
End Sub`

Thanks for your reply

I generate an automatic report with VBA to populate my doc, and tables and titles after that I would like to create a link between specific cells and titles. And after I would like to do the reverse create a Linked between the title to come back to the equivalent table. It will be easier to explain during a review

Answer 1

This sort-of works for me, with the exception that the links into a table only go to the first cell and not the intended one...

I added the bookmarks since creating "bi-directional" links didn't seem to work by itself.

Sub Create_Hyperlink_between_tables_and_Titles()
    
    Dim tbl As Table, cel As Cell, txt As String, bkMkNum As Long
    Dim NameList As String, rng As Range, doc As Document, bkmk As Bookmark
    
    Set doc = ActiveDocument
    
    ClearLinksAndBookmarks doc 'for testing
    
    ' Search only Tables and create a list of cells name
    For Each tbl In doc.Range.Tables
        For Each cel In tbl.Range.Cells
            txt = cel.Range.Text
            NameList = Mid(cel.Range.Text, 1, Len(txt) - 2)
            If Len(NameList) > 4 Then
                Set rng = ActiveDocument.Range
                With rng.Find
                    .ClearFormatting
                    .Forward = True
                    .Wrap = wdFindContinue
                    .Format = True
                    .Style = "Heading 2"
                    .Text = NameList
                    .Execute
                    If .Found = True Then
                        AddLinkWithBookmark cel.Range, rng, bkMkNum
                        AddLinkWithBookmark rng, cel.Range, bkMkNum
                    End If
                End With
            End If  'long enough cell content
        Next cel
    Next tbl
End Sub

'Add a hyperlink between `fromRange` and `toRange`: create a bookmark for `toRange`
Sub AddLinkWithBookmark(fromRange As Range, toRange As Range, ByRef bmNum As Long)
    Dim bkmk As Bookmark, doc As Document
    bmNum = bmNum + 1 'increment counter for bookmark name
    Set doc = toRange.Document
    Set bkmk = doc.Bookmarks.Add(Name:="BMHL_" & Format(bmNum, "000"), Range:=toRange)
    doc.Hyperlinks.Add Anchor:=fromRange, Address:="", _
                       SubAddress:=bkmk, ScreenTip:=""
End Sub

'for testing - reset document state
Sub ClearLinksAndBookmarks(doc As Document)
    Dim i As Long
    For i = doc.Hyperlinks.Count To 1 Step -1
        doc.Hyperlinks(i).Delete
    Next i
    For i = doc.Bookmarks.Count To 1 Step -1
        With doc.Bookmarks(i)
            If .Name Like "BMHL_*" Then .Delete
        End With
    Next i
End Sub