Sub MarkIt()
' Paul Beverley - Version 25.10.23
' Applies various attributes by (wildcard) F&R

confirmMarkItList = True
' confirmMarkItList = False

On Error GoTo ReportIt
myTrack = ActiveDocument.TrackRevisions
ActiveDocument.TrackRevisions = False
Set workDoc = ActiveDocument

myResponse = vbNo
For Each listDoc In Application.Documents
  DoEvents
  pNum = listDoc.Paragraphs.Count
  myNum = 3
  If pNum < 3 Then myNum = pNum
  Set rng = listDoc.Paragraphs(myNum).Range
  rng.Start = 0
  If InStr(LCase(rng.Text), "markit") Then
    listDoc.Activate
    listDoc.Windows(1).WindowState = wdWindowStateNormal
    If confirmMarkItList = True Then
      myResponse = MsgBox("Is this your MarkIt list?", _
           vbQuestion + vbYesNo, "MarkIt")
    Else
      myResponse = vbYes
    End If
    If myResponse = vbYes Then Exit For
  End If
Next listDoc

If myResponse <> vbYes Then
  Beep
  myResponse = MsgBox("Can't find a MarkIt list." & vbCr & vbCr & _
       "Please ensure that your MarkIt list is open and starts with:" _
       & vbCr & vbCr & "| MarkIt", vbExclamation + vbOKOnly, "MarkIt")
  Exit Sub
End If

If listDoc = workDoc Then
  Beep
  myResponse = MsgBox("Please place the cursor in the text to be marked." _
       & vbCr & vbCr & "and rerun MarkIt.", vbExclamation + vbOKOnly, _
       "MarkIt")
  Exit Sub
End If

' Now do the F&Rs
workDoc.Activate
Set rng = Selection.Range.Duplicate
Selection.HomeKey Unit:=wdStory

Set main = ActiveDocument.Content
doFoots = ActiveDocument.Footnotes.Count > 0
doEnds = ActiveDocument.Endnotes.Count > 0

If doFoots Then Set foots = workDoc.StoryRanges(wdFootnotesStory)
If doEnds Then Set ends = workDoc.StoryRanges(wdEndnotesStory)
oldColour = Options.DefaultHighlightColorIndex

numLines = listDoc.Paragraphs.Count
ReDim myText(numLines) As String
ReDim isItalic(numLines) As Boolean
ReDim isBold(numLines) As Boolean
ReDim isUline(numLines) As Boolean
ReDim isWild(numLines) As Boolean
ReDim doMatch(numLines) As Boolean
ReDim hiColour(numLines) As Long
ReDim textColour(numLines) As Long

For i = 1 To 40
  mySPs = mySPs & "    "
Next i
mySPs = mySPs & "To go: "
' First fill arrays for all the F&Rs needed
i = 0
For Each ma In listDoc.Paragraphs
  ' Only do anything if there's text on the line
  doThis = (Len(ma) > 2)
  Debug.Print ma.Range.Text
  If doThis = True And Left(ma.Range.Text, 1) <> ChrW(124) _
       And ma.Range.Characters(1).Font.StrikeThrough = False Then
    i = i + 1
    myText(i) = Replace(ma.Range.Text, vbCr, "")
    ' Check for any wildcard characters
    isWild(i) = False
    If InStr(myText(i), "[") > 0 Then isWild(i) = True
    If InStr(myText(i), "<") > 0 Then isWild(i) = True
    If InStr(myText(i), ">") > 0 Then isWild(i) = True
    ' Check for bent pipe = any case
    If Left(myText(i), 1) = ChrW(172) Then
      myText(i) = Mid(myText(i), 2)
      doMatch(i) = False
    Else
      doMatch(i) = True
    End If
    isItalic(i) = ma.Range.Font.Italic
    isBold(i) = ma.Range.Font.Bold
    isUline(i) = ma.Range.Font.Underline
    hiColour(i) = ma.Range.HighlightColorIndex
    textColour(i) = ma.Range.Font.Color
    ' First three are neg if true;
    '   second two are positive if true.
    ' So if you're asking for none of these, ignore this line
    If (isItalic(i) + isBold(i) + isUline(i) + hiColour(i) = 0) And _
         (textColour(i) < 1) Then i = i - 1
  End If
Next ma
numFRs = i

For i = 1 To numFRs
  Options.DefaultHighlightColorIndex = hiColour(i)
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = myText(i)
    .Wrap = wdFindContinue
    .Forward = True
    .Replacement.Text = ""
    If isItalic(i) Then .Replacement.Font.Italic = True
    If isBold(i) Then .Replacement.Font.Bold = True
    If isUline(i) Then .Replacement.Font.Underline = True
    If hiColour(i) > 0 Then .Replacement.Highlight = True
    If textColour(i) > 0 Then .Replacement.Font.Color = textColour(i)
    .MatchCase = doMatch(i)
    .MatchWildcards = isWild(i)
    .Execute Replace:=wdReplaceAll
    DoEvents
  End With
  
  If doFoots Then
    With foots.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = myText(i)
      .Wrap = wdFindContinue
      .Forward = True
      .Replacement.Text = ""
      If isItalic(i) Then .Replacement.Font.Italic = True
      If isBold(i) Then .Replacement.Font.Bold = True
      If isUline(i) Then .Replacement.Font.Underline = True
      If hiColour(i) > 0 Then .Replacement.Highlight = True
      If textColour(i) > 0 Then .Replacement.Font.Color = textColour(i)
      .MatchCase = doMatch(i)
      .MatchWildcards = isWild(i)
      .Execute Replace:=wdReplaceAll
      DoEvents
    End With
  End If
  
  If doEnds Then
    With ends.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Text = myText
      .Wrap = wdFindContinue
      .Forward = True
      .Replacement.Text = ""
      If isItalic(i) Then .Replacement.Font.Italic = True
      If isBold(i) Then .Replacement.Font.Bold = True
      If isUline(i) Then .Replacement.Font.Underline = True
      If hiColour(i) > 0 Then .Replacement.Highlight = True
      If textColour(i) > 0 Then .Replacement.Font.Color = textColour
      .MatchCase = doMatch(i)
      .MatchWildcards = isWild(i)
      .Execute Replace:=wdReplaceAll
      DoEvents
    End With
  End If
  StatusBar = mySPs & Str(numFRs - i)
  Debug.Print mySPs & Str(numFRs - i)
Next i
Options.DefaultHighlightColorIndex = oldColour
With Selection.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Wrap = wdFindContinue
  .Forward = True
  .Replacement.Text = ""
  .MatchCase = False
  .MatchWildcards = False
  DoEvents
End With
ActiveDocument.TrackRevisions = myTrack
StatusBar = ""
rng.Select
Beep
myTime = Timer
Do
Loop Until Timer > myTime + 0.2
Beep
Exit Sub

ReportIt:
Application.ScreenUpdating = True
ern = Err.Number
If ern = 9118 Or ern = 5590 Or ern = 5560 Or ern = 5692 Then
  ActiveDocument.ActiveWindow.LargeScroll down:=1
  ma.Range.Select
  ActiveDocument.ActiveWindow.SmallScroll down:=1
  Beep
  MsgBox "Wildcard error"
  Err.Clear
Else
  On Error GoTo 0
  Resume
End If
End Sub