Sub InstantFindUp()
' Paul Beverley - Version 08.03.23
' Finds selected text upwards

doTrim = True
addBookmark = True
butNotTheseFiles = "zzSwitchList,ComputerTools4Eds,TheMacros,5_Library"

Set rng = Selection.Range.Duplicate
If rng.Start = rng.End Then
  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
startNow = Selection.Start
Selection.Collapse wdCollapseStart
myName = ActiveDocument.Name
dotPos = InStr(myName, ".")
If dotPos > 0 Then myName = Left(myName, dotPos - 1)
noMarker = (InStr(butNotTheseFiles, myName) > 0)
If InStr(myName, "Ch") > 0 Then noMarker = True
If addBookmark = True And noMarker = False Then _
     ActiveDocument.Bookmarks.Add Name:="myTempMark2"
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
  .Forward = False
  .Text = thisBit
  .Replacement.Text = thisBit
  .MatchCase = False
  If UCase(thisBit) = thisBit Then .MatchCase = True
  .MatchWildcards = makeWild
  .MatchWholeWord = False
  .MatchSoundsLike = False
  .Execute
End With

If Selection.Start = startNow And _
     Selection.Find.Found = False Then Beep
     
' Leaves F&R dialogue in a sensible state
With Selection.Find
  .Wrap = wdFindContinue
  .Forward = True
End With
End Sub