Create automatic index in Word based on Headings with VBA

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:

Code:

---

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

---

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.

Quote:

---

Originally Posted by 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.

---

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

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

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

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

Quote:

---

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

Code:

---

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.

---

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