Excel: Create a TOC linked to a Word Doc

If you need to create an Excel document, and you need to refer to certain sections of a Word document, it's possible to create direct links to bookmarks. This means you can click on a cell in Excel and go directly to a section in the Word doc.

Sub ConvertWordBookmarkToHyperLink()

' Converts a Word Table of Contents into direct links to the

' relevant section of the Word document.

' Edward Chan 2022

' To use:

' 1. Enter the path and name of the Word Document in Cell B2.

' Note: If the Word doc is in the same folder as the Excel document then

' just enter the filename.

' 2. Copy and paste the Table of Contents from Word into A2 onwards.

' 3. In Excel, select the filename and heading titles.

' 4. Run this macro.

' If you want the links to have the heading titles,

' copy-paste values of the heading titles over the resultant links.

Dim Rng As Range

Dim WorkRng As Range

Dim FileName As Range

On Error Resume Next

xTitleId = "Select Contents pasted from Word Doc"

Set WorkRng = Application.Selection

Set WorkRng = Application.InputBox("Range", xTitleId, WorkRng.Address, Type:=8)

xTitleId = "Select the filename of the Word Doc"

Set FileName = Application.InputBox("Range", xTitleId, WorkRng(1).Address, Type:=8)

For Each Rng In WorkRng

Rng.Offset(0, 1).Value = FileName.Value & "#" & Rng.Hyperlinks(1).SubAddress

Application.ActiveSheet.Hyperlinks.Add Rng.Offset(0, 1), Rng.Offset(0, 1).Value

Rng.Offset(0, 1).Value = Rng.Value

End Sub

NOTE: This is also possible with HTML files, but only if the file is HTTP (not local), since Word strips the # character.

Here is a macro to extract hyperlinks from cells if you just need to do that:

Sub ExtractHyperLink()

' Extracts a hyperlink from a cell

Dim rng As range

Dim workrng As range

On Error Resume Next

xTitleId = "Select Hyperlinks"

Set workrng = Application.Selection

Set workrng = Application.InputBox("Range", xTitleId, workrng.Address, Type:=8)

For Each rng In workrng

rng.Offset(0, 1).Value = rng.Hyperlinks(1).SubAddress

End Sub