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