Sub InstantFindDown()
' Paul Beverley - Version 14.03.24
' Finds selected text downwards

doTrim = True
addBookmark = True

butNotTheseFiles = "zzSwitchList,ComputerTools4Eds,TheMacros,5_Library,VideoList"

Set rng = Selection.Range.Duplicate
If rng.Start = rng.End Then
  rng.MoveEnd , 1
  If rng.Text = vbCr Then
    rng.MoveEnd , -2
  Else
    rng.Collapse wdCollapseStart
  End If
  rng.Expand wdWord
  For i = 1 To 3
    If InStr(ChrW(8217) & " '", Right(rng.Text, 1)) > 0 Then _
         rng.End = rng.End - 1
  Next i
End If
thisBit = rng.Text
endNow = Selection.End
Selection.Collapse wdCollapseStart
myName = ActiveDocument.Name
dotPos = InStr(myName, ".")
If dotPos > 0 Then myName = Left(myName, dotPos - 1)
noMarker = (InStr(LCase(butNotTheseFiles), LCase(myName)) > 0)
If InStr(myName, "Ch") > 0 Then noMarker = True
If addBookmark = True And noMarker = False Then _
     ActiveDocument.Bookmarks.Add Name:="myTempMark2"
Selection.Start = endNow

If Asc(thisBit) <> 32 And doTrim Then thisBit = Trim(thisBit)
thisBit = Replace(thisBit, "^", "^^")
thisBit = Replace(thisBit, vbCr, "^p")
thisBit = Replace(thisBit, vbTab, "^t")

With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Wrap = wdFindStop
  .Text = thisBit
  .Replacement.Text = thisBit
  .MatchWildcards = False
  .MatchCase = False
  If UCase(thisBit) = thisBit Then .MatchCase = True
  .MatchWholeWord = False
  .Forward = True
  .Execute
End With
If Selection.End = endNow And _
     Selection.Find.Found = False Then Beep
' Leaves F&R dialogue in a sensible state
Selection.Find.Wrap = wdFindContinue
End Sub