Sub InstantFindBottom()
' Paul Beverley - Version 25.02.11
' I couldn't possibly comment!

If Selection.Start = Selection.End Then
  Selection.MoveRight Unit:=wdWord, Count:=1
  Selection.MoveLeft Unit:=wdWord, Count:=1, Extend:=wdExtend
End If

thisBit = Trim(Selection)
Selection.Start = Selection.End
Selection.EndKey Unit:=wdStory
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Wrap = False
  .Text = thisBit
  .Replacement.Text = thisBit
  .MatchWildcards = False
  .MatchWholeWord = False
  .MatchCase = False
  .Forward = False
  .Execute
End With
' Move the screen display down a couple of lines
Selection.MoveUp Unit:=wdLine, Count:=2
Selection.MoveDown Unit:=wdLine, Count:=2
Selection.Find.Execute
' Leaves F&R dialogue in a sensible state
With Selection.Find
  .Wrap = wdFindContinue
  .Forward = True
End With
End Sub