I need a Macro that will find sentences containing: shall, will, must statements. Currently I am using the following:

Sub ShredNew()
Application.ScreenUpdating = False
Dim ExcelApp As Object, ExcelWB As Object, ExcelWS As Object
Dim StrFnd As String, StrOut As String, i As Long, j As Long
Dim Rng As Range
Set ExcelApp = CreateObject("Excel.Application")
ExcelApp.Visible = False
Set ExcelWB = ExcelApp.Workbooks.Add
Set ExcelWS = ExcelWB.Sheets(1)
StrFnd = "shall,will,must"
Msg = "This macro finds all Shall, Will and Must statements and " & _
"exports them to an Excel file with both " & _
"section and page number defined." & vbCr & vbCr & _
"Do you want to continue?"
If MsgBox(Msg, vbYesNo + vbQuestion, Title) <> vbYes Then
Exit Sub
End If
For i = 0 To UBound(Split(StrFnd, ","))
With ActiveDocument.Range
With .Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = Split(StrFnd, ",")(i)
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
Do While .Find.Found
j = j + 1
Set Rng = .Duplicate
With Rng


.Expand Unit:=wdSentence
If Asc(.Characters.Last.Text) < 33 Then .End = .End - 1
If .Characters.Last.Next.Text = LCase(.Characters.Last.Next.Text) Then
.MoveEnd wdSentence, 1
End If
While .Words.First.Previous.Text Like "[eig]"
.MoveStart wdSentence, -1
Wend
If .Characters.Last.Text Like "[" & vbCr & Chr(11) & vbTab & "]" Then .End = .End - 1
StrOut = Trim(.Text)
End With
ExcelWS.Cells(j, 2).Value = StrOut
With Rng
.Expand Unit:=wdSentence
If Asc(.Characters.Last.Text) < 33 Then .End = .End - 1
If .Characters.Last.Next.Text = LCase(.Characters.Last.Next.Text) Then
.MoveEnd wdSentence, 1
End If
While .Words.First.Previous.Text Like "[eig]"
.MoveStart wdSentence, -1
Wend
If .Characters.Last.Text Like "[" & vbCr & Chr(11) & vbTab & "]" Then .End = .End - 1
StrOut = Trim(.Text)
End With
ExcelWS.Cells(j, 3).Value = .Information(wdActiveEndAdjustedPageNumber)
StrOut = ""
If .Paragraphs.First.Range.ListParagraphs.Count = 1 Then
StrOut = .Paragraphs.First.Range.ListFormat.ListString
End If
If Not .Paragraphs.First.Range.ListFormat.ListString Like "[0-9]*" Then
While (Not .Paragraphs.First.Range.ListFormat.ListString Like "[0-9]*") And _
(Not .Paragraphs.First.Range.Words.First Like "Appendix*")
.MoveStart wdParagraph, -1
Wend
If .Paragraphs.First.Range.Words.First Like "Appendix*" Then
StrOut = "Appendix " & Split(.Paragraphs.First.Range.Text, " ")(1) & StrOut
Else
StrOut = .Paragraphs.First.Range.ListFormat.ListString & StrOut
End If
End If
ExcelWS.Cells(j, 1).Value = StrOut
.Collapse wdCollapseEnd
'.Start = Rng.End
.Find.Execute
Loop
End With

Next
With ExcelApp
.Visible = True
.DisplayAlerts = False
ExcelWB.SaveAs
.DisplayAlerts = True
End With
Set ExcelWS = Nothing: Set ExcelWB = Nothing: Set ExcelApp = Nothing: Set Rng = Nothing
Application.ScreenUpdating = True
End Sub

So the issue is that certain documents I am using this macro on have been converted from .pdf and therefore they lose some formatting, such as the automatically numbered headers.

Any help appreciated.

V/r,
Logan Valentine