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