Word macro to extract text by style and capture numbering if style contains list numbering (2)

New ticket for a closed issue (https://www.experts-exchange.com/questions/29141120/Word-macro-to-extract-text-by-style-and-capture-numbering-if-style-contains-list-numbering.html?anchor=a42871864¬ificationFollowed=230273679#a42871864):
I have a macro to extract all text that has a user-defined style to a new document but also to include the numbering if the style is a numbering style. The latest version works very well for all but one style: Intense Reference. When I enter this style, the macro goes into an endless loop.  This was a problem on several styles in previous versions. This was fixed by an EE expert but for some reason, only the 'Intense Reference' style causes the endless loop. If this can be repaired, the macro will be good to go. I successfully tested the other styles in the table on p. 1 of the attached file.
Extract-Text-by-Style-Test-May-28-2.docm
marrick13Asked:
Who is Participating?
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

irudykCommented:
FYI, the link you provided is to a question you have not closed.
irudykCommented:
Try the following revised code which should fix thee issue you outlined. It should also fix the issue with the footnotes and endnotes.

Sub Extract_Text_by_Style_Old3()
'May 26 2019 - revised by irudyk at Experts Exchange to address the list numbering not being included in the extract.
Dim rText As Range, oRange As Range
Dim oDoc As Document
Dim oNewDoc As Document
Dim uStyle As String, oRng As Range
Dim pResult As String, lngStyleCount As Long, DefStyle As String
Dim vbmFlags As VbMsgBoxStyle, vbmResult As VbMsgBoxResult, strMsg As String
Dim PageNum As Integer, LineNum As String
Dim i As Integer
Dim intTextEnd As Long
Dim intLastFoundPosition As Long
Dim uStyleAlt As String

uStyleAlt = ""

DefStyle = "Heading 1"
   
uInput:
 pResult = InputBox("Enter style whose text you want to extract to a new document.", "Style Name", DefStyle)
 pResult = RealInput(pResult)
 If pResult = "Input cancelled." Then
   Exit Sub
   End If
 If pResult = "" Then GoTo uInput
  uStyle = pResult 'assign psresult to ustyle if latter is not blank
  
If uStyle = "Footnote Text" Then uStyleAlt = "Footnote Reference"
If uStyle = "Endnote Text" Then uStyleAlt = "Endnote Reference"

Set oDoc = ActiveDocument
'Get count of style instances
On Error GoTo StyleError


  Set oRng = oDoc.Range
  With oRng.Find
    .ClearFormatting
    .Wrap = wdFindStop
    .Forward = True
    .Format = True
    .MatchWildcards = False
    .Text = ""
    .Style = oDoc.Styles(IIf(uStyleAlt = "", uStyle, uStyleAlt))
    Do While .Execute
       lngStyleCount = lngStyleCount + 1
       If oRng.End = oDoc.Range.End Or oRng.End = intLastFoundPosition Then Exit Do
       oRng.Collapse wdCollapseEnd
       intLastFoundPosition = oRng.End
    Loop
  End With

If lngStyleCount = 0 Then
    MsgBox "No text was found to extract for the style '" & uStyle & "'.", vbOKOnly, "Style Use Search"
    Exit Sub
End If

strMsg = "Instances of '" & uStyle & "' found: " & lngStyleCount & "." & vbCr & vbCr _
& "Do you want to export the text using this style to a new document?"

vbmFlags = vbYesNo
If lngStyleCount > 0 Then
    vbmResult = MsgBox(strMsg, vbmFlags, "Instance count")
End If

Select Case vbmResult
Case vbNo
    Exit Sub
End Select
    
    Set oNewDoc = Documents.Add
    Set rText = oDoc.Range
    
    'Insert page number and count in footer of output document
oNewDoc.Sections(oNewDoc.Sections.Count) _
.Footers(wdHeaderFooterPrimary).Range.Select
With Selection
    .Paragraphs(1).Alignment = wdAlignParagraphCenter
    .TypeText Text:="p. "
    .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="PAGE ", preserveFormatting:=True
    .TypeText Text:=" of "
    .Fields.Add Range:=Selection.Range, Type:=wdFieldEmpty, Text:="NUMPAGES ", preserveFormatting:=True
End With

If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
    ActiveWindow.Panes(2).Close
End If

If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
    ActivePane.View.Type = wdOutlineView Then
    ActiveWindow.ActivePane.View.Type = wdPrintView
End If

ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.EscapeKey
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
If ActiveWindow.View.SplitSpecial = wdPaneNone Then
    ActiveWindow.ActivePane.View.Type = wdPrintView
Else
    ActiveWindow.View.Type = wdPrintView
End If
    'Write style name at top
    oNewDoc.Range.InsertAfter "Style: '" & uStyle & "'" & " / Occurrences: " & lngStyleCount & vbCr
    With rText.Find
        .Style = oDoc.Styles(IIf(uStyleAlt = "", uStyle, uStyleAlt))
        Do While .Execute
            PageNum = rText.Information(wdActiveEndAdjustedPageNumber)
            LineNum = rText.Information(wdFirstCharacterLineNumber)
            i = i + 1
            If rText.ListFormat.ListType = wdListBullet Then
                oNewDoc.Range.InsertAfter "Page: " & PageNum & "/" & "Line: " & LineNum & vbCr & _
                    ChrW(AscW(rText.ListFormat.ListTemplate.ListLevels(rText.ListFormat.ListLevelNumber).NumberFormat)) & " " & rText & vbCr
                oNewDoc.Range(oNewDoc.Range.End - Len(rText) - 3, oNewDoc.Range.End - Len(rText) - 2).Font.Name _
                    = rText.ListFormat.ListTemplate.ListLevels(rText.ListFormat.ListLevelNumber).Font.Name
            Else
                If rText.Footnotes.Count = 0 And rText.Endnotes.Count = 0 Then
                    oNewDoc.Range.InsertAfter "Page: " & PageNum & "/" & "Line: " & LineNum & vbCr & Trim(rText.ListFormat.ListString & " " & rText) & vbCr
                ElseIf rText.Endnotes.Count <> 0 Then
                    If uStyleAlt = "" Then
                        oNewDoc.Range.InsertAfter "Page: " & PageNum & "/" & "Line: " & LineNum & vbCr & Trim(rText.ListFormat.ListString & " " & rText.Endnotes(1).Index) & vbCr
                    Else
                        oNewDoc.Range.InsertAfter "Page: " & PageNum & "/" & "Line: " & LineNum & vbCr & Trim(rText.ListFormat.ListString & " " & rText.Endnotes(1).Index & " " & rText.Endnotes(1).Range.Text) & vbCr
                    End If
                Else
                    If uStyleAlt = "" Then
                        oNewDoc.Range.InsertAfter "Page: " & PageNum & "/" & "Line: " & LineNum & vbCr & Trim(rText.ListFormat.ListString & " " & rText.Footnotes(1).Index) & vbCr
                    Else
                        oNewDoc.Range.InsertAfter "Page: " & PageNum & "/" & "Line: " & LineNum & vbCr & Trim(rText.ListFormat.ListString & " " & rText.Footnotes(1).Index & " " & rText.Footnotes(1).Range.Text) & vbCr
                    End If
                   
                End If
            End If
            rText.Collapse wdCollapseEnd
            If rText.End >= oDoc.Range.End - 1 Or rText.End = intLastFoundPosition Then Exit Do
            intLastFoundPosition = rText.End
            If i > lngStyleCount Then
                MsgBox "There is a data problem in this document that is causing an endless loop. Program will stop now. Look for data that is unnecessarily repeating in the extract and remove it in the source document and try again.", vbOKOnly, "Endless loop message"
            Exit Sub
            End If
        Loop
    End With

'Remove page breaks in output document
With oNewDoc
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^m" 'use ^b to replace all section breaks or ^n replace all column breaks
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchByte = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
        .MatchFuzzy = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End With

StyleError:
    If Err.Number <> 0 Then
        MsgBox "Style doesn't exist.", vbOKOnly, "Style Name Check"
    Exit Sub
End If
End Sub

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
marrick13Author Commented:
This is great! It solves all the known problems. Thanks so much.
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
VBA

From novice to tech pro — start learning today.