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