Sub MakeTOCBasedOnFN()
    CreateTableContentsForCurrentSection "myStyle"
End Sub

Sub CreateTableContentsForCurrentSection(styleName As String)
        
    Dim curSec As Section
    Set curSec = GetCurrrentSection
    
    Dim texts As New Collection
    
    ScanSectionFootNotes curSec, texts, styleName
    InsertTableOfContents texts

End Sub

Sub InsertTableOfContents(texts As Collection)

    Dim paras As New Collection
    Dim rng As Range
    Dim i As Integer
    For i = 1 To texts.Count
        Set rng = texts(i)
        Selection.TypeText rng.text
        paras.Add Selection.Range.Duplicate
        Selection.TypeText vbCr
    Next
    
    Dim paraRng As Range
    For i = 1 To paras.Count
        Set rng = texts(i)
        Set paraRng = paras(i)
        paraRng.text = " " & rng.Information(wdActiveEndAdjustedPageNumber)
    Next
    
End Sub

Sub ScanSectionFootNotes(sec As Section, texts As Collection, styleName As String)

    Dim orginalSelection As Range
    Set orginalSelection = Selection.Range.Duplicate
    
    Dim fn As Footnote
    Dim findRenge As Range
    Dim i As Integer
    For i = 1 To sec.Range.Footnotes.Count
        Set fn = sec.Range.Footnotes(i)
        Set findRenge = fn.Range.Duplicate
        Do
            If Not (findRenge.Style Is Nothing) Then
                If findRenge.Style = ActiveDocument.Styles(styleName) Then
                    texts.Add findRenge.Duplicate
                    Exit Do
                End If
            End If
            With findRenge.Find
                .ClearFormatting
                .Replacement.ClearFormatting
                .Style = styleName
                .text = ""
                .Replacement.text = ""
                .Format = True
                .Forward = True
                .Wrap = wdFindStop
                
                If Not .Execute Then Exit Do
                              
                texts.Add findRenge.Duplicate
                findRenge.Collapse wdCollapseEnd
                findRenge.End = fn.Range.End
                If findRenge.text = "" Then Exit Do
            End With
        Loop
    Next
    
    orginalSelection.Select
    
End Sub=

Function GetCurrrentSection() As Section

    Dim sec As Section
    For Each sec In ActiveDocument.Sections
        If Selection.Start >= sec.Range.Start And Selection.Start <= sec.Range.End Then
            Set GetCurrrentSection = sec
            Exit Function
        End If
    Next
    
    Err.Raise 111111, , "Current secton not found"
    
End Function