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