Try the following. Just don't expect stellar performance.
Code:
Sub ShadingTest()
Dim Rng As Range, Clr As Long, i As Long, StrOut As String, Tbl As Table
With ActiveDocument
Set Rng = .Range(0, 0)
With Rng
Do While .End < ActiveDocument.Range.End
Clr = .Characters.First.Shading.BackgroundPatternColor
Do While .Characters.Last.Next.Shading.BackgroundPatternColor = Clr
If .End = ActiveDocument.Range.End - 1 Then Exit Do
.End = .End + 1
Loop
Select Case Clr
Case wdColorAutomatic, wdColorWhite
Case Else
i = i + 1
StrOut = StrOut & vbCr & i & vbTab & .Start & "-" & .End & vbTab & _
GetRGB(.Font.Shading.BackgroundPatternColor) & vbTab & .Text
End Select
.Collapse wdCollapseEnd
.End = .End + 1
Loop
.InsertAfter "Item" & vbTab & "Range" & vbTab & "R" & vbTab & "G" & vbTab & "B" & vbTab & "Content:" & StrOut
.ConvertToTable
.End = .End + 1
With .Tables(1)
.Columns.AutoFit
.Sort Excludeheader:=True, _
FieldNumber:=3, SortFieldType:=wdSortFieldNumeric, SortOrder:=wdSortOrderAscending, _
FieldNumber2:=4, SortFieldType2:=wdSortFieldNumeric, SortOrder2:=wdSortOrderAscending, _
FieldNumber3:=5, SortFieldType3:=wdSortFieldNumeric, SortOrder3:=wdSortOrderAscending
End With
End With
End With
End Sub
Function GetRGB(RGBvalue As Long) As String
Dim StrTmp As String
If RGBvalue < 0 Or RGBvalue > 16777215 Then RGBvalue = 0
StrTmp = RGBvalue \ 256 ^ 0 Mod 256
StrTmp = StrTmp & vbTab & RGBvalue \ 256 ^ 1 Mod 256
StrTmp = StrTmp & vbTab & RGBvalue \ 256 ^ 2 Mod 256
GetRGB = StrTmp
End Function