nanopod,
I did try the latest code you posted, and you're right -- it's a lot slower. Over 6 times slower on the test.docx, as you can see below in the comparison I made.
In this comparison, results from the Demo_modified() code I posted are on the left and result from your latest code is on the right. The text in red font shows where your latest code produced different results. Your latest code accurately reports the shading in test.docx for the 3 cases which differ. The differences here are minor, however: just a space or non-printing character. The range start differences are also minor, and it's not clear to me which one is correct.
For completeness, I'm also including the Excel version of the Demo_modified() code that I find most helpful. Although I first verified that the code we've been discussing works in Word, I prefer to work in Excel for a number of reasons.
Code:
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