Sub CitationAlyseProcess()
' Paul Beverley - Version 29.03.24
' Removes "obvious" matches from a CitationAlyse list

Set rngAll = ActiveDocument.Content
Documents.Add
Set rng = ActiveDocument.Content
rng.FormattedText = rngAll.FormattedText
Set rngAll = ActiveDocument.Content
rng.Font.Underline = False
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "."
  .Wrap = wdFindContinue
  .Forward = True
  .Replacement.Text = ""
  .MatchWildcards = False
  .Execute Replace:=wdReplaceAll
  DoEvents
  .Text = "^p"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .Replacement.Font.Color = wdBlack
  .Execute Replace:=wdReplaceAll
  DoEvents
  
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = "[\(\)]"
  .Wrap = wdFindContinue
  .Replacement.Text = ""
  .MatchWildcards = True
  .Execute Replace:=wdReplaceAll
  DoEvents
End With

With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Font.Color = wdColorBlue
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = False
  .Execute
End With

Do While rng.Find.Found = True
  myName = Trim(rng.Text)
  nameStart = rng.Start
  rng.Collapse wdCollapseEnd
  rng.MoveEnd wdWord, 1
  myYear = rng.Text
  rng.Start = nameStart
  rng.Font.Underline = True
  rngAll.Collapse wdCollapseEnd
  With rngAll.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = myName & "[ ,a-zA-Z\-" & ChrW(8217) & "]{1,}" & myYear
    .Wrap = wdFindContinue
    .Font.Underline = False
    .Replacement.Text = ""
    .MatchWildcards = True
    .Execute
    If rngAll.Text = rng.Text Then
      rngAll.Font.Underline = True
      .Execute
    End If
  rngAll.Expand wdParagraph
    If rngAll.Words.Count < 12 Then
    .Execute
    End If
  End With
  If rngAll.Find.Found Then
    rng.Font.Color = wdColorGray25
    ' You have to apply a highlight, then remove it because
    ' VBA refuses to remove the highlight on a single space!
    rng.HighlightColorIndex = wdYellow
    rng.HighlightColorIndex = wdNoHighlight
    rngAll.Expand wdParagraph
    rngAll.Font.Color = wdColorGray25
    rngAll.HighlightColorIndex = wdNoHighlight
    rngAll.Collapse wdCollapseEnd
  End If
  rng.Collapse wdCollapseEnd
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ""
    .Font.Color = wdColorBlue
    .Font.Underline = False
    .Wrap = wdFindStop
    .Replacement.Text = ""
    .Forward = True
    .MatchWildcards = False
    .MatchWholeWord = False
    .Execute
  End With
  DoEvents

  myCount = myCount + 1
  If myCount Mod 20 = 0 Then rng.Select
Loop

Set rng = ActiveDocument.Content
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Font.Color = wdColorBlue
  .Wrap = wdFindStop
  .Replacement.Text = ""
  .Forward = True
  .MatchWildcards = False
  .Execute
End With

Do While rng.Find.Found = True
  myCount = myCount + 1
  If myCount Mod 20 = 0 Then rng.Select
Loop

Selection.HomeKey Unit:=wdStory
End Sub