Sub Demo_modified_Excel()
' note: this is Excel VBA that manipulates a Word document
' so you must add a reference to the Word-library (Microsoft Word 16.0 Object Library)
' also assumes Word doc is located at Z:\test.docx
Dim wApp As Word.Application, wDoc As Word.Document, wRng As Word.Range
Dim sh As Worksheet, r As Range, kD As Date
Dim i As Long, j As Long
Dim shdColor As Long, k As Long, st As Long
Const filePath = "Z:\test.docx"
kD = Now
Set sh = ThisWorkbook.ActiveSheet
Set r = sh.Range("A1") 'prepare for output to Excel
sh.Cells.Clear
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
Set wDoc = wApp.Documents.Open(filePath)
With wDoc.Range
  With .Find
    .ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Execute Replace:=wdReplaceAll
    .Wrap = wdFindStop
    .Font.Shading.BackgroundPatternColor = wdColorAutomatic
  End With
  Do While .Find.Execute
    i = .Start: Set wRng = wDoc.Range(j, .Start)
    With wRng.Font.Shading
      Select Case .BackgroundPatternColor
        Case wdColorAutomatic
        Case wdColorWhite
        Case wdUndefined '9999999  ie, mix of shade colors
          st = wRng.Start
          shdColor = wDoc.Range(st, st).Font.Shading.BackgroundPatternColor
          k = st + 1
          Do
            k = k + 1
            If wDoc.Range(k, k).Font.Shading.BackgroundPatternColor <> shdColor Then
              If shdColor <> wdColorWhite Then
                If wDoc.Range(st - 1, st - 1).Font.Superscript Then st = st + 1
                shadeOutput r, st, k, wDoc.Range(st - 1, k), shdColor
              End If
              st = k + 1
              shdColor = wDoc.Range(st, st).Font.Shading.BackgroundPatternColor
            End If
          Loop Until k >= wRng.End
        'deal with real colors; ie, not white, auto or mixed
        Case Else: shadeOutput r, wRng.Start, wRng.End, wRng.Text, .BackgroundPatternColor
      End Select
    End With 
    If .End = wDoc.Range.End Then Exit Do
    .Collapse wdCollapseEnd
    j = .End
  Loop
End With
Columns("A:D").EntireColumn.AutoFit
wApp.Quit True
Set wDoc = Nothing
Set wApp = Nothing
r = r.Row - 1 & " shaded regions found. Elapsed time: " & Format((Now - kD), "HH:MM:SS")
sh.Activate
r.Select
End Sub

Sub shadeOutput(r As Range, st As Long, ed As Long, txt As String, shd As Long)
With r 'ouput info about each shaded region on active sheet
  .Offset(0, 0) = st  'start point for shaded text
  .Offset(0, 1) = ed 'ending point for shaded text
  .Offset(0, 2) = txt
  .Offset(0, 2).Interior.Color = shd
  .Offset(0, 3) = shd
End With
Set r = r.Offset(1, 0)
End Sub