Sub callShadingFinder()
'This code loops through all word files in the same directory as the Excel document
Dim s As String
Const ext = "docx"
s = dir(ThisWorkbook.path & "\*" & ext)
While s <> ""
  ThisWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = Left(s, InStr(s, ext) - 2)
  shadingFinder ThisWorkbook.path & "\" & s
  s = dir()
Wend
End Sub

Sub shadingFinder(filePath As String)
'problems: includes para mark when shading at end of line
Dim wApp As Word.Application, wDoc As Word.Document, wRng As Word.Range
Dim sh As Worksheet, r As Range, kD As Date
Dim shdColor As Long, shdStart As Long, shdEnd As Long
kD = Now
Set sh = ThisWorkbook.ActiveSheet
'Set testR = sh.Range("F1")
Set r = sh.Range("A1") 'prepare Excel to list output
sh.Cells.Clear
Set wApp = CreateObject("Word.Application")
Set wDoc = wApp.Documents.Open(filePath)
wApp.Visible = False
Application.ScreenUpdating = False
With wDoc.Range
  With .Find 'determine where shaded text is based on where unshaded text is
    .ClearFormatting
    .Text = ""
    .Replacement.Text = ""
    .Forward = True
    .Execute Replace:=wdReplaceAll
    .Wrap = wdFindStop
    .Font.Shading.BackgroundPatternColor = wdColorAutomatic 'unshaded text
  End With
  '.range(0,1] =first char of doc, .range(1,2] =second char, ...
  Do While .Find.Execute
    shdEnd = .Start: Set wRng = wDoc.Range(shdStart, shdEnd)
    With wRng.Font.Shading
      Select Case .BackgroundPatternColor
        Case wdColorAutomatic
        Case wdColorWhite
        Case wdUndefined '9999999  ie, mix of shade colors
          'step thru each char comparing its shading with first shaded char
          shdColor = wDoc.Range(shdStart, shdStart + 1).Font.Shading.BackgroundPatternColor
          shdEnd = shdStart
          Do
            shdEnd = shdEnd + 1
            If wDoc.Range(shdEnd, shdEnd + 1).Font.Shading.BackgroundPatternColor <> shdColor Then
              If shdColor <> wdColorWhite Then
                  shadeOutput r, shdStart, shdEnd, wDoc.Range(shdStart, shdEnd), shdColor
              End If
              'redefine first shaded character
              shdStart = shdEnd
              shdColor = wDoc.Range(shdStart, shdStart + 1).Font.Shading.BackgroundPatternColor
            End If
          Loop Until shdEnd >= 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
    shdStart = .End
    Application.StatusBar = "for " & filePath & ": " & r.Row - 1 & " shaded regions found: " & Format(shdStart / wDoc.Characters.Count, "0%")
  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
Application.ScreenUpdating = True
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