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.

[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.

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....