Sub ListHighlightedOrColoured()
' Paul Beverley - Version 09.09.17
' Lists alphabetically any text that is highlighted

removeColouration = True

myColour = Selection.range.Font.ColorIndex
myHighlight = Selection.range.HighlightColorIndex
styleColour = Selection.range.Style.Font.ColorIndex
If myColour + myHighlight = 0 Then
  MsgBox "Please place the cursor in the colour to be listed."
  Exit Sub
End If
If myColour > 0 And myColour = styleColour Then
  MsgBox "Sorry, this macro doesn't work with colours in styles."
  Exit Sub
End If

Set rngOld = ActiveDocument.Content
Documents.Add
Set rng = ActiveDocument.Content
rng.FormattedText = rngOld.FormattedText
rng.Font.StrikeThrough = True
' Wait for repagination to complete
Selection.EndKey Unit:=wdStory
Selection.HomeKey Unit:=wdStory
mixedColour = 9999999
If myHighlight > 0 Then
  For Each myPara In rng.Paragraphs
    col = myPara.range.HighlightColorIndex
    If col <> mixedColour Then
      If col = myHighlight Then myPara.range.Font.StrikeThrough = False
    Else
      For Each wd In myPara.range.Words
        col = wd.HighlightColorIndex
        If col <> mixedColour Then
          If col = myHighlight Then wd.Font.StrikeThrough = False
        Else
          For Each ch In wd.Characters
            col = ch.HighlightColorIndex
            If col <> mixedColour Then
              If col = myHighlight Then ch.Font.StrikeThrough = False
            End If
            DoEvents
          Next ch
        End If
        DoEvents
      Next wd
    End If
    DoEvents
    j = j + 1
    If j Mod 25 = 0 Then myPara.range.Select
  Next myPara
Else
  For Each myPara In rng.Paragraphs
    col = myPara.range.Font.ColorIndex
    If col <> mixedColour Then
      If col = myColour Then myPara.range.Font.StrikeThrough = False
    Else
      For Each wd In myPara.range.Words
        col = wd.Font.ColorIndex
        If col <> mixedColour Then
          If col = myColour Then wd.Font.StrikeThrough = False
        Else
          For Each ch In wd.Characters
            col = ch.Font.ColorIndex
            If col <> mixedColour Then
              If col = myColour Then ch.Font.StrikeThrough = False
            End If
            DoEvents
          Next ch
        End If
        DoEvents
      Next wd
    End If
    DoEvents
  Next myPara
End If

Set rng = ActiveDocument.Content
If removeColouration = True Then
  rng.Font.ColorIndex = 0
  rng.HighlightColorIndex = 0
End If
With rng.Find
  .ClearFormatting
  .Replacement.ClearFormatting
  .Text = ""
  .Wrap = wdFindContinue
  .Replacement.Text = "^p"
  .Font.StrikeThrough = True
  .Execute Replace:=wdReplaceAll
End With
myResponse = MsgBox("Sort?", vbQuestion _
        + vbYesNoCancel, "ListHighlightedOrColoured")
Set rng = ActiveDocument.Content
If myResponse = vbYes Then
  rng.Sort SortOrder:=wdSortOrderAscending
  Selection.EndKey Unit:=wdStory
  Selection.TypeText Text:=vbCr
  Selection.HomeKey Unit:=wdStory
  Selection.Expand wdParagraph
  Do While Len(Selection) = 1
    Selection.Delete
    Selection.Expand wdParagraph
  Loop
  Selection.HomeKey Unit:=wdStory
  Beep
Else
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "^13{1,}"
    .Wrap = wdFindContinue
    .Replacement.Text = "^p"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
  End With
  Selection.HomeKey Unit:=wdStory
  Set rng = ActiveDocument.Paragraphs(1).range
  If Asc(rng) = 13 Then rng.Delete
End If
End Sub