After learning more, I've improved the code I posted above. This version improves accuracy and is faster.
Again, this is Excel VBA which manipulates Word documents so for it to work you need to do this in the IDE: Tools>References...>Microsoft Word 16.0 Object Library
Code:
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