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

doTrim = True
addBookmark = True

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

If Selection.Start = Selection.End Then
  Selection.Expand wdWord
  For i = 1 To 3
    If InStr(ChrW(8217) & " '", Right(Selection.Text, 1)) > 0 Then _
         Selection.MoveEnd , -1
  Next i
End If

If Selection.Font.DoubleStrikeThrough = True Then
  Selection.Expand wdParagraph
  Selection.Collapse wdCollapseEnd
  With Selection.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Wrap = wdFindStop
    .Text = ""
    .Font.DoubleStrikeThrough = True
    .Replacement.Text = ""
    .MatchWildcards = False
    .MatchCase = False
    .Forward = True
    .Execute
  End With
  Exit Sub
End If

thisBit = Selection

makeWild = False
If Right(thisBit, 1) = ">" Then makeWild = True
If Left(thisBit, 1) = "<" Then makeWild = True
wordEnd = 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 = wordEnd

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

If makeWild = True Then
  thisBit = Replace(thisBit, vbCr, "^p")
Else
  thisBit = Replace(thisBit, vbCr, "^13")
End If
thisBit = Replace(thisBit, vbTab, "^t")


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