Sub FindFootnotePages()
Dim i As Long, Rng As Range, j As Long, k As Long, StrPages As String
With ActiveDocument
  If .ComputeStatistics(wdStatisticPages) > .Footnotes.Count Then
    For i = 1 To .Footnotes.Count
      If .Footnotes(i).Range.Information(wdActiveEndPageNumber) > k Then
        k = .Footnotes(i).Range.Information(wdActiveEndPageNumber)
        j = j + 1
        StrPages = StrPages & k & " "
      End If
    Next
  Else
    For i = 1 To .ComputeStatistics(wdStatisticPages)
      Set Rng = ActiveDocument.GoTo(What:=wdGoToPage, Name:=i)
      Set Rng = Rng.GoTo(What:=wdGoToBookmark, Name:="\page")
      If Rng.Footnotes.Count > 0 Then
        j = j + 1
        StrPages = StrPages & i & " "
      End If
    Next
  End If
  If j <> 0 Then
    StrPages = " references, on pages: " & vbCr & Replace(Trim(StrPages), " ", ", ") & "."
  Else
    StrPages = "s."
  End If
  MsgBox "The document: " & .Name & " contains " & j & " footnote" & StrPages
End With
Set Rng = Nothing
End Sub

  Dim aPage As Page
  Dim j As Long, k As Long, l As Long, m As Long, x As Long, y As Long
  j = ActiveDocument.ComputeStatistics(wdStatisticPages) 'Total Page Count
  k = 0 'keeps track of current page being analyzed
  l = 0 'counts Separator Story
  m = 0 'counts Continuation Separator Story
  For Each aPage In ActiveDocument.ActiveWindow.ActivePane.Pages
    k = k + 1
    x = aPage.Rectangles.count 'counts Rectangles on each Page
    For y = 1 To x 'cycles through Rectangles on each Page
      If aPage.Rectangles.Item(y).RectangleType = wdTextRectangle Then
        If aPage.Rectangles.Item(y).Range.StoryType = wdFootnoteSeparatorStory Then
          l = l + 1
        End If
        If aPage.Rectangles.Item(y).Range.StoryType = wdFootnoteContinuationSeparatorStory Then
          m = m + 1
        End If
      End If
    Next
  Next
  Debug.Print l + m