Hi Graham,

the result of your code looks nicer
than mine because of the additional vbtab.

Also, I didn't feel like finding out
what numerical equivalent each colorindex has.
I usually leave such things to the original poster.

I don't think there is an elegant way to achieve that.
What possible ways there are you know as good as me,
and, certainly, you need no advice on that.

Schönen Abend noch.
(Have a nice evening.)

Kgollan,

Adding FirstFind in Graham's subroutine may help it to output only found
color text headings.

Sub ExtractHiLight()
Dim FirstFind as Boolean
Dim rDcm As Range
Dim lClr As Long      ' color index
Dim sCol As String
Dim Doc1 As Document
Dim Doc2 As Document
If ActiveDocument.Content.HighlightColorIndex <> 0 then
Set Doc1 = ActiveDocument
Set Doc2 = Documents.Add
Doc1.Activate
For lClr = 1 To 16
   FirstFind = True
   Select Case lClr
       Case 1
           sCol = "Black"
       Case 2
           sCol = "Blue"
       Case 3
           sCol = "Turquoise"
       Case 4
           sCol = "Bright green"
       Case 5
           sCol = "Pink"
       Case 6
           sCol = "Red"
       Case 7
           sCol = "Yellow"
       Case 8
           sCol = "White"
       Case 9
           sCol = "Dark blue"
       Case 10
           sCol = "Teal"
       Case 11
           sCol = "Green"
       Case 12
           sCol = "Violet"
       Case 13
           sCol = "Dark red"
       Case 14
           sCol = "Dark yellow"
       Case 15
           sCol = "50% gray"
       Case 16
           sCol = "25% gray"
   End Select

  Set rDcm = Doc1.Range
  With rDcm.Find
     .Highlight = True
     While .Execute
        If rDcm.HighlightColorIndex = lClr Then
           If FirstFind then
               Doc2.Range.InsertAfter sCol & vbCr
               FirstFind = False
           End If
           Doc2.Range.InsertAfter vbTab & rDcm.Text & vbCr
        End If
     Wend
  End With
Next
Else
   MsgBox "No Highlighting found."
End If
End Sub