Sub ExtractHighShadeText()
Dim Exc As Excel.Application
Dim Wb As Excel.Workbook
Dim Ws As Excel.Worksheet
Dim s As String, Rw As Long
Set Exc = CreateObject("Excel.Application")
Exc.Visible = True
Set Wb = Exc.Workbooks.add
Set Ws = Wb.Sheets(1)
Rw = 0

Dim Rng As Range, StartChr As Long, EndChr As Long, OldColor As Long, Clr As Long
''''''''''''''''''''HiLight''''''''''''''''''
Set Rng = ActiveDocument.Characters(1)
OldColor = Rng.Font.Color
Selection.HomeKey Unit:=wdStory

        With Selection.Find
            .ClearFormatting
            .Text = ""
            .Highlight = True
            .Font.BOLD = True
            Do While .Execute

            'These two line Converting HighlightColorIndex to RGB Color
            Rng.Font.ColorIndex = Selection.Range.HighlightColorIndex
            Clr = Rng.Font.Color

            Rw = Rw + 1
            Ws.Cells(Rw, 1).value = Selection.Text
            'Ws.Cells(Rw, 1).Interior.ColorIndex = Selection.Range.HighlightColorIndex
            Ws.Cells(Rw, 1).Interior.Color = Clr
            'For sorting on HighlightColorIndex
            'Ws.Cells(Rw, 2).Value = Selection.Range.HighlightColorIndex
            'For sorting on HighlightColorIndex RGB value
            Ws.Cells(Rw, 2).value = Clr
            Loop
        End With
Rng.Font.Color = OldColor
'''End Hilight''''''''''''''''''''''''''''''

'WorkAround used for converting highlightColorIndex to Color RGB value
StartChr = 1
EndChr = 0
Set Rng = ActiveDocument.Characters(1)

Selection.HomeKey Unit:=wdStory
        With Selection.Find
            .ClearFormatting
            .Text = ""

            '.Highlight = True
            .Font.Shading.BackgroundPatternColor = wdColorAutomatic

            Do While .Execute
              EndChr = Selection.Start
              Debug.Print Selection.Start, Selection.End, StartChr, EndChr, IIf(EndChr > StartChr, "-OK", "")

              If EndChr > StartChr Then
              Set Rng = ActiveDocument.Range(Start:=StartChr, End:=EndChr)
              Clr = Rng.Font.Shading.BackgroundPatternColor
              Rw = Rw + 1
              Ws.Cells(Rw, 1).value = Rng.Text
              Ws.Cells(Rw, 1).Interior.Color = Clr
              Ws.Cells(Rw, 2).value = Clr
              End If
              StartChr = Selection.End
            Loop

              If EndChr > StartChr Then
              Set Rng = ActiveDocument.Range(Start:=StartChr, End:=EndChr)
              Clr = Rng.Font.Shading.BackgroundPatternColor
              Rw = Rw + 1
              Ws.Cells(Rw, 1).value = Rng.Text
              Ws.Cells(Rw, 1).Interior.Color = Clr
              Ws.Cells(Rw, 2).value = Clr
              End If

        End With


    If Rw > 1 Then
    Ws.Range("A1:B" & Rw).Sort Key1:=Ws.Range("B1"), Order1:=xlAscending, Header:=xlNo
    Ws.Range("B1:B" & Rw).ClearContents
    End If
End Sub

Private strWorkbook As String
Private strSheet As String

strWorkbook = BrowseForFile("Select Workbook", True)
If Not strWorkbook = vbNullString Then

strSheet = "sheet1"

Private Function BrowseForFile(Optional strTitle As String, Optional bExcel As Boolean) As String
Dim fDialog As FileDialog
    On Error GoTo err_Handler
    Set fDialog = Application.FileDialog(msoFileDialogFilePicker)
    With fDialog
        .Title = strTitle
        .AllowMultiSelect = False
        .Filters.Clear
        If bExcel Then
            .Filters.add "Excel workbooks", "*.xls,*.xlsx,*.xlsm"
        Else
            .Filters.add "Word documents", "*.doc,*.docx,*.docm"
        End If
        .InitialView = msoFileDialogViewList
        If .Show <> -1 Then GoTo err_Handler:
        BrowseForFile = fDialog.SelectedItems.Item(1)
    End With
lbl_Exit:
    Exit Function
err_Handler:
    BrowseForFile = vbNullString
    Resume lbl_Exit
End Function