Create automatic index in Word based on Headings with VBA

[johan_wouter]

Hi,

I've made family cookbook in Word and with every new item I'm able to renew the TOC with that new item (recipe). The items in the TOC also have hyperlinks to the specific recipe and every Heading has a hyperlink, that brings you back to the TOC. However, all the recipes are added after the last recipe and this makes the TOC difficult to read.
I would like to create an alphabetical index at the end of my document, with all the headings of recipes and respective pages, and the index items also hyperlinked to the recipes.
I'm a bit at a loss how to do this. I can mark a heading for an index. But how to do this in VBA? Also to mark the index item as an hyperlink?

I would appreciate your help.

I've added the TOC macro below:


Sub UpdateTOC()
' Update TOC and hyperlinks Macro
Application.ScreenUpdating = False
Dim hyp As Hyperlink
Dim toc As TableOfContents
Dim k As Long
Dim bkmk As String
Dim sCode As String
Dim fld As Field
Dim aRange As Range
If ActiveDocument.TablesOfContents.Count = 0 Then
MsgBox "There are no Tables of Contents in document"
Exit Sub
End If
If ActiveDocument.TablesOfContents.Count = 1 Then _
ActiveDocument.TablesOfContents(1).Update
Set toc = ActiveDocument.TablesOfContents(1)
For Each fld In toc.Range.Fields
sCode = fld.Code.Text
If InStr(sCode, "HYPERLINK") > 0 Then
bkmk = Mid(sCode, InStr(sCode, "_"))

bkmk = Left(bkmk, Len(bkmk) - 2)

fld.Select

ActiveDocument.Bookmarks.Add Range:=Selection.Range, _

Name:=bkmk & "R"
Set aRange = ActiveDocument.Bookmarks(bkmk).Range

aRange.Select

With ActiveDocument.Hyperlinks.Add(Anchor:=Selection.Range, _

Address:="", SubAddress:=bkmk & "R", _

TextToDisplay:=Selection.Text)

.Range.Select

Selection.ClearCharacterAllFormatting

End With
End If
Next fld
Options.CtrlClickHyperlinkToOpen = False

Selection.GoTo What:=wdGoToBookmark, Name:="Inhoud"
Application.ScreenUpdating = True
End Sub

[Chas Kenyon]

The Table of Contents and the Index are different fields and the Index field does not have hyperlink capability built into it.
I believe you can find macros to assign hyperlinks to an Index in the Word vba forum (https://www.msofficeforums.com/word-vba/).

[johan_wouter]

The Table of Contents and the Index are different fields and the Index field does not have hyperlink capability built into it.
I believe you can find macros to assign hyperlinks to an Index in the Word vba forum (https://www.msofficeforums.com/word-vba/).

Dear Chas,
Thanks for replying. I know that TOC and Index are different. The macro I submitted makes an automatic TOC with hyperlinks. However, since the added recipes are not added in alphabetical order, it becomes difficult to search. Therefor I would like to add an Index. This is automatically alphabetical. But I'm looking for a macro to transform every heading into an Index item and then create an Index with hyperlinks.
If you know where to find the macro to assign hyperlinks to an Index...?
Greetings, johan

[johan_wouter]

Hi everyone, I could use some more help on this one...

[AyeletR]

Hi, I could use help with accomplishing this exact thing. Did anyone ever come up with the macro that could do it? TIA

[Aussiebear]

A fellow VBAX 'er Macropod, came up with this concept


You could create a Table of Contents, convert that to a table, then sort the table. The following macro does just that:


Sub CreateIndexTable()
Dim TOC As TableOfContents, Rng As Range, Tbl As Table
Dim StrBkMkList As String, StrStlList As String, StrTmp As String, i As Long
With ActiveDocument
If .Bookmarks.Exists("TblTOC") Then
.Bookmarks("TblTOC").Range.Delete
.Bookmarks("TblTOC").Delete
End If
Set TOC = .TablesOfContents.Add(Range:=Selection.Range, UseHeadingStyles:=True, IncludePageNumbers:=True)
With TOC
For i = 3 To .Range.Fields.Count
StrBkMkList = StrBkMkList & "|" & Split(Trim(.Range.Fields(i).Code.Text), " ")(1)
StrStlList = StrStlList & "|" & .Range.Paragraphs(i - 2).Style
Next
Set Rng = .Range
.Delete
End With
Set Tbl = .Tables.Add(Range:=Rng, NumRows:=i - 2, NumColumns:=2)
With Tbl
.Borders.Enable = True
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 90
.Rows.Alignment = wdAlignRowCenter
.Rows(1).HeadingFormat = True
.Rows(1).Range.Style = "Strong"
With .Columns(1)
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 90
End With
With .Columns(2)
.PreferredWidthType = wdPreferredWidthPercent
.PreferredWidth = 10
End With
With .Cell(1, 1).Range
.Text = "Poem"
End With
With .Cell(1, 2).Range
.Text = "Page"
End With
End With
For i = 1 To UBound(Split(StrBkMkList, "|"))
StrTmp = Replace(Split(StrBkMkList, "|")(i), "Toc", "TblTOC")
.Bookmarks.Add Name:=StrTmp, Range:=.Bookmarks(Split(StrBkMkList, "|")(i)).Range
.Bookmarks(Split(StrBkMkList, "|")(i)).Delete
Set Rng = Tbl.Cell(i + 1, 1).Range
With Rng
.Style = Split(StrStlList, "|")(i)
.End = .End - 1
.Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:="REF " & StrTmp & " \h", PreserveFormatting:=False
End With
Set Rng = Tbl.Cell(i + 1, 2).Range
With Rng
.Style = Split(StrStlList, "|")(i)
.End = .End - 1
.Fields.Add Range:=Rng, Type:=wdFieldEmpty, Text:="PAGEREF " & StrTmp & " \h", PreserveFormatting:=False
.ParagraphFormat.Alignment = wdAlignParagraphRight
End With
Next
Tbl.Range.Fields.Update
Tbl.Sort ExcludeHeader:=True, FieldNumber:=1, SortFieldType:=wdSortFieldAlphanumeric, SortOrder:=wdSortOrderAscending
End With
End Sub


Note: If you add/delete headings, you'll need to delete the table & run the macro again.

[Aussiebear]

Well it appears that assistance went to the dogs....