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

Sub InsertTableOfContents(colTCFields As Collection)
Dim oRng As Range
Dim lngIndex As Long
Dim strEntry As String

  ReDim arrEntries(colTCFields.Count - 1, 1)
  For lngIndex = 1 To colTCFields.Count
    Set oRng = colTCFields(lngIndex).Code
    strEntry = Right(oRng.Text, Len(oRng.Text) - 5)
    arrEntries(lngIndex - 1, 0) = strEntry
    arrEntries(lngIndex - 1, 1) = oRng.Information(wdActiveEndAdjustedPageNumber)
    'Selection.TypeText strEntry & " - " & oRng.Information(wdActiveEndAdjustedPageNumber) & vbCr
  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)
Dim oFN As Footnote
Dim oField As Field
Dim lngIndex As Long
   For Each oField In oSec.Range.Fields
     If oField.Type = wdFieldTOCEntry Then
       colTCFields.Add oField
     End If
   Next oField
lbl_Exit:
  Exit Sub
End Sub
Sub ScanSectionFootNotes(oSec As Section, colTCFields As Collection)
Dim oFN As Footnote
Dim oField As Field
Dim lngIndex As Long
  For lngIndex = 1 To oSec.Range.Footnotes.Count
    Set oFN = oSec.Range.Footnotes(lngIndex)
    For Each oField In oFN.Range.Fields
      If oField.Type = wdFieldTOCEntry Then
        If oField.Code.Information(wdInFootnote) Then
          colTCFields.Add oField
        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
  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
    oRng.Collapse wdCollapseEnd
  Next lngIndex
lbl_Exit:
  Exit Sub
End Sub