Unable to delete Paragraphs in Word Docs Processed from Excel

[HikingHawaii]

Hi and thank you in advance for considering my question.

I need to use VBA in Excel to resolve the following issue: We have word documents that are generated from a training development application. The documents generate titles with Heading 3 and Heading 4 styles that are duplicated in the following line as bolded text (the Word style is wdStyleStrong).

Example in Word:

The solution is to enter the path and filename of each document in Excel and have Excel process each document while providing status updates on the process. Ideally, the procedure executes the following tasks:

1. Counts the number of documents to process and uses the path and filename to open the first document.
2. Counts the number of Heading 3 and Heading 4 paragraphs.
3. Redims two separate array variables
4. Fills the arrays with the text of each heading
5. Searches the document for the exact string and format (wdStyleStrong)
6. and deletes both the text and the paragraph.

Example in Excel:

The problem is with step 6. I am able to find and delete the text but not delete the paragraph along with it.

I have little experience with Word in VBA and definitely need some direction here. Of course, if anyone has an entirely better solution which can just find each instance of Heading 3 and 4 and then delete the paragraph following each that would be awesome. As for now, I can't figure out how to work with the paragraph object to do that.

Here is the code:

Sub RemoveConceptHeader()
Dim a As Integer
Dim b As Integer
Dim c As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
Dim objWord As Word.Application
Dim objDoc As Word.Document
Dim TextToFind As String
Dim TextToFind2 As String
Dim txtCt3 As Long
Dim txtCt4 As Long
Dim arr3() As Variant
Dim arr4() As Variant
Dim lg3 As Long
Dim lg4 As Long
Dim oRng As Object
Set wbBook = ThisWorkbook
a = wbBook.Worksheets("Sheet1").Cells(200, 1).End(xlUp).Row 'Find number of last row

For b = 6 To a 'Loop through Path/File list
txtCt3 = 0 'Counts the occurances of Heading 3
txtCt4 = 0 'Counts the occurances of Heading 4
lg3 = 0 'Counts up the Heading 3 Array
lg4 = 0 'Counts up the Heading 4 Array
c = wbBook.Worksheets("Sheet1").Cells(b, 1) & "" & wbBook.Worksheets("Sheet1").Cells(b, 2)
wbBook.Worksheets("Sheet1").Cells(b, 3) = ""
Set objWord = New Word.Application 'Set Word Application and Object Variables
Set objDoc = objWord.Documents.Open(c)

If Dir(c) <> "" Then ' Open Word document
wbBook.Worksheets("Sheet1").Cells(b, 3) = "Counting Headings"
'Count number of Headings
With objDoc.Content.Find 'Count all Heading 3
.Style = wdStyleHeading3
Do While .Execute(FindText:="", Forward:=True, Format:=True) = True
txtCt3 = 1 + txtCt3
Loop
End With
With objDoc.Content.Find 'Count all Heading 4
.Style = wdStyleHeading4
Do While .Execute(FindText:="", Forward:=True, Format:=True) = True
txtCt4 = 1 + txtCt4
Loop
End With
ReDim arr3(0 To txtCt3) 'set Array to the heading 3 total
'Populate Array with text to search
wbBook.Worksheets("Sheet1").Cells(b, 3) = "Collecting Heading Names"
With objDoc.Content.Find 'Assign values to array
.Style = wdStyleHeading3
Do While .Execute(FindText:="", Forward:=True, Format:=True) = True
TextToFind = Left$(.Parent.Text, Len(.Parent.Text) - 1)
arr3(lg3) = TextToFind
lg3 = lg3 + 1
Loop
End With

ReDim arr4(0 To txtCt4) 'set Array to the heading 4 total
With objDoc.Content.Find 'Assign values to array
.Style = wdStyleHeading4
Do While .Execute(FindText:="", Forward:=True, Format:=True) = True
TextToFind2 = Left$(.Parent.Text, Len(.Parent.Text) - 1)
arr4(lg4) = TextToFind2
lg4 = lg4 + 1
Loop
End With
wbBook.Worksheets("Sheet1").Cells(b, 3) = "Deleting Duplicate Titles"
'Derive search string from array and delete from document
With objDoc.Content.Find 'Delete all Heading 3 text from the Bold/Normal style
For lg3 = LBound(arr3) To UBound(arr3)
.ClearFormatting
.Font.Bold = True
.Style = wdStyleStrong
.Text = arr3(lg3)
.Replacement.ClearFormatting
.Replacement.Text = ""
.Execute Replace:=wdReplaceOne, Forward:=True
.Wrap = wdFindContinue
Next lg3
End With

With objDoc.Content.Find 'Delete all Heading 4 text from the Bold/Normal style
For lg4 = LBound(arr4) To UBound(arr4)
.ClearFormatting
.Font.Bold = True
.Style = wdStyleStrong
.Text = arr4(lg4)
.Replacement.ClearFormatting
.Replacement.Text = ""
.Execute Replace:=wdReplaceOne, Forward:=True
.Wrap = wdFindContinue
Next lg4
End With
wbBook.Worksheets("Sheet1").Cells(b, 3) = "Process Complete"
Else 'Indicate file or path missing or incorrect
wbBook.Worksheets("Sheet1").Cells(b, 3) = "File and/or Path does not exist or is incorrect."
End If
objDoc.Save
objDoc.Close
Set objDoc = Nothing
Next b

Application.ScreenUpdating = True
End Sub

 

[HikingHawaii]

Another attempt at loading the images:




https://cdn.pbrd.co/images/GN7N9jU.png

 

[HikingHawaii]