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