Option Explicit
Dim arrEntries() As String
Sub CreateCompositeTOC_CurrentSection()
Dim oSec As Section
Dim colTCFields As New Collection
Dim colBMs As New Collection
  Set oSec = ActiveDocument.Sections(Selection.Information(wdActiveEndSectionNumber))
  ScanSection oSec, colTCFields, colBMs
  ScanSectionFootNotes oSec, colTCFields, colBMs
  BuildTOCContent colTCFields, colBMs
  DisplayTOC
lbl_Exit:
  Exit Sub
End Sub

Sub BuildTOCContent(colTCFields As Collection, colBMs As Collection)
Dim oRng As Range
Dim lngIndex As Long
Dim strEntry As String

  ReDim arrEntries(colTCFields.Count - 1, 2)
  For lngIndex = 1 To colTCFields.Count
    Set oRng = colTCFields(lngIndex).Code
    strEntry = Right(oRng.Text, Len(oRng.Text) - 5)
    If InStr(strEntry, "\l") > 0 Then
      strEntry = Mid(strEntry, 1, InStr(strEntry, "\l") - 2)
    End If
    strEntry = Replace(strEntry, "/" & Chr(34), Chr(34))
    strEntry = Replace(strEntry, "/" & ChrW(8220), ChrW(8220))
    strEntry = Replace(strEntry, "/" & ChrW(8221), ChrW(8221))
    arrEntries(lngIndex - 1, 0) = strEntry
    arrEntries(lngIndex - 1, 1) = oRng.Information(wdActiveEndAdjustedPageNumber)
    arrEntries(lngIndex - 1, 2) = colBMs.Item(lngIndex)
  Next lngIndex
  'Sort on page number
  WordBasic.SortArray arrEntries(), 0, 0, UBound(arrEntries), 0, 1
  'Sort on entry
  WordBasic.SortArray arrEntries(), 0, 0, UBound(arrEntries), 0, 1
lbl_Exit:
  Exit Sub
End Sub
Sub ScanSection(oSec As Section, colTCFields As Collection, colBMs As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngFieldIndex As Long
  lngFieldIndex = 1
   For Each oField In oSec.Range.Fields
     If oField.Type = wdFieldTOCEntry Then
       oField.Code.Bookmarks.Add "Sec_" & oSec.Index & "Fld_" & lngFieldIndex, oField.Code
       colTCFields.Add oField
       colBMs.Add "Sec_" & oSec.Index & "Fld_" & lngFieldIndex
       lngFieldIndex = lngFieldIndex + 1
     End If
   Next oField
lbl_Exit:
  Exit Sub
End Sub
Sub ScanSectionFootNotes(oSec As Section, colTCFields As Collection, colBMs As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngIndex As Long
Dim lngFieldIndex
  For lngIndex = 1 To oSec.Range.Footnotes.Count
    Set oFN = oSec.Range.Footnotes(lngIndex)
    lngFieldIndex = 1
    For Each oField In oFN.Range.Fields
      If oField.Type = wdFieldTOCEntry Then
        If oField.Code.Information(wdInFootnote) Then
          oField.Code.Bookmarks.Add "Sec_" & oSec.Index & "FN_" & lngIndex & "Fld_" & lngFieldIndex, oField.Code
          colTCFields.Add oField
          colBMs.Add "Sec_" & oSec.Index & "FN_" & lngIndex & "Fld_" & lngFieldIndex
          lngFieldIndex = lngFieldIndex + 1
        End If
      End If
    Next oField
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub

Sub DisplayTOC()
Dim oRng As Range
Dim lngIndex As Long
Dim oStyle As Style
Dim oRngHL As Range
Dim oHL As Hyperlink
  On Error Resume Next
  Set oStyle = ActiveDocument.Styles("CompositeTOC")
  If Err.Number <> 0 Then
    ActiveDocument.Styles.Add "CompositeTOC", wdStyleTypeParagraph
    With ActiveDocument.Styles("CompositeTOC")
      .BaseStyle = ActiveDocument.Styles("TOC 1")
      .ParagraphFormat.TabStops.Add Position:=InchesToPoints(6.5), Alignment:=wdAlignTabRight, Leader:=wdTabLeaderDots
      .NextParagraphStyle = ActiveDocument.Styles("CompositeTOC")
    End With
  End If
  On Error GoTo 0
  Set oRng = Selection.Range
  oRng.Style = "CompositeTOC"
  For lngIndex = 0 To UBound(arrEntries)
    oRng.Text = arrEntries(lngIndex, 0) & vbTab & arrEntries(lngIndex, 1) & vbCr
    Set oRngHL = oRng.Duplicate
    oRngHL.End = oRngHL.End - 1
    oRngHL.Hyperlinks.Add oRngHL, , arrEntries(lngIndex, 2)
    oRng.Collapse wdCollapseEnd
    oRngHL.Collapse wdCollapseEnd
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub