Large Word Doc with many Duplicate Headings

Hey folks!

I have an issue I would love some help with. I have a document that gets spit out from an enterprise tool I use for work, and due to how things are set up, many Heading 2 headings are doubled.

I'm trying to get a macro together that will find Heading 2 headings and delete them if they have no content, OR if they are immediately followed by another Heading 2 heading that is identical (always the first Heading needs to be removed)

I tried this code:

Code:

---

Sub RemoveHeadingsWithNoContent()


Dim HeadingF As Range
Set HeadingF = ActiveDocument.Content


With HeadingF.Find
    .Style = "Heading 2"
    .Forward = True
    .Wrap = wdFindStop
End With


Do
    HeadingF.Find.Execute
    If HeadingF.Find.Found Then


        If HeadingF.Paragraphs(1).Next.Range.Style <> "Normal" Then


            HeadingF.Delete


        End If
    End If
Loop While HeadingF.Find.Found


End Sub

---

That seems to work on smaller test documents, but the ones I need this macro to run on are from 4000 - 10000 pages long. When I run this on the proper document, it freezes up Word. I have tried leaving it overnight and it never recovers.

Any suggestions would be greatly appreciated. I am very new to VBA, so this is throwing me for a loop.

Can you attach a small sample?

Academic Dates 2019/2020

Academic Dates 2019/2020

ACADEMIC CLASS ADD/DROP DATES

Term Identifier

Part of Term Description

Duration of Classes

Last Day to Change and Add Classes for registered students

Last Day to Drop without “W” Last Day to Change from Audit to Credit and Vice Versa

Last Day to Drop with “W”

Summer Term 2019

1 (UG), 2 (GR)	Full Term	May 6 - July 30, 2019	May 21, 2019	June 5, 2019	July 5, 2019
9	12-week Term	May 30 - August 23, 2019	June 12, 2019	June 26, 2019	July 24, 2019
A	7-week Term	May 6 - June 24, 2019	May 13, 2019	May 21, 2019	June 6, 2019
D	3-week Term	May 6 - May 28, 2019	May 8, 2019	May 10, 2019	May 17, 2019
E	3-week Term	May 30 - June 20, 2019	June 3, 2019	June 5, 2019	June 12, 2019
B	7-week Term	July 2 - August 20, 2019	July 9, 2019	July 17, 2019	August 2, 2019
F	3-week Term	July 2 - July 23, 2019	July 4, 2019	July 8, 2019	July 15, 2019
G	3-week Term	July 25 - August 16, 2019	July 29, 2019	July 31, 2019	August 7, 2019
4		May 1 - August 31, 2019	May 21, 2019	June 5, 2019	July 5, 2019

Fall Term 2019

X/Y	Full Year Class	September 3, 2019 - April 6, 2020	September 18, 2019	October 31, 2019	February 4, 2020
1 (UG), 2 (GR)	Full Term	September 3 - December 3, 2019	September 18, 2019	October 2, 2019	October 31, 2019

Winter Term 2020

1 (UG), 2 (GR)	Full Term	January 6 - April 6, 2020	January 17, 2020	January 31, 2020	March 9, 2020
Q	4th-year Nursing	January 6 - March 13, 2020	January 15, 2020	January 27, 2020	February 24, 2020

Summer Term 2020

1 (UG), 2 (GR)	Full Term	May 4 - July 27, 2020	May 18, 2020	June 2, 2020	July 2, 2020
9	12-week Term	June 4 - August 28, 2020	June 10, 2020	June 24, 2020	July 22, 2020
A	7-week Term	May 11 - June 29, 2020	May 18, 2020	May 26, 2020	June 11, 2020
D	3-week Term	May 11 - June 2, 2020	May 13, 2020	May 15, 2020	May 22, 2020
E	3-week Term	June 4 - June 25, 2020	June 8, 2020	June 10, 2020	June 17, 2020
B	7-week Term	July 6 - August 24, 2020	July 13, 2020	July 21, 2020	August 6, 2020
F	3-week Term	July 6 - July 27, 2020	July 8, 2020	July 10, 2020	July 17, 2020
G	3-week Term	July 29 - August 20, 2020	July 31, 2020	August 4, 2020	August 11, 2020
4		May 1 - August 31, 2020	May 18, 2020	June 2, 2020	July 2, 2020

Other Academic Dates

2019
May
Monday, 6	Co-op and Academic Summer term begins
Friday, 10	Convocation (Faculty of Agriculture)
Monday, 20	Victoria Day - University closed
Monday, 27 - Saturday, June 1	Spring Convocations
July
Monday, 1	Last day to apply to graduate in the Fall University closed in lieu of Canada Day
Tuesday, 30	Co-op summer academic term ends
Wednesday, 31	Examinations begin commerce co-op, computer science & engineering
August
Monday, 5	Halifax/Dartmouth Natal Day - University closed
Saturday, 6	Examinations end except commerce co-op
Wednesday, 14	Examinations end commerce co-op
September
Monday, 2	Labour Day - University closed
Tuesday, 3	Classes begin, fall term
Wednesday, 18	Last day to apply for honours programs
October
Monday, 7 and Tuesday, 8	Fall Convocations
Monday, 14	Thanksgiving Day - University closed
November
Monday, 11 - Friday, 15	Fall Study Week (except students in Co-op Clinicals, or Internships)
Monday, 11	University closed in lieu of Remembrance Day
December
Sunday, 1	Last day to apply to graduate in the Spring
Tuesday, 3 *	Classes end, fall term * Tuesday, December 3 - Monday classes will be held
Thursday, 5	Examinations begin
Sunday, 15	Examinations end
Monday, 23	Grades due for courses with formal exams
2020
January
Wednesday, 1	New Year's Day - University closed
Monday, 6	Classes begin, winter term
February
Friday, 7
Monday, 17 - Friday, 21	Winter Study Week
Monday, 17	Nova Scotia Heritage Day - University closed
April
Monday, 6 **	Classes end, regular session ** Monday, April 6 - Friday classes will be held
Wednesday, 8	Examinations begin, regular session
Friday, 10	Good Friday - University closed
Friday, 24	Examinations end, regular session
May
Friday, 1	Grades due for courses with formal exams
Monday, 4	Co-op and academic summer term begins
Monday, 18	Victoria Day - University closed
Monday, 25 - Sunday, 31	Spring Convocations
July
Wednesday, 1	Last day to apply to graduate in October University closed in lieu of Canada Day
Monday, 27	Co-op Summer academic term ends
Wednesday, 29	Examinations begin, commerce co-op, computer science and engineering
August
Monday, 3	Halifax/Dartmouth Natal Day - University closed
Wednesday, 5	Examinations end, except commerce co-op
Wednesday, 12	Examinations end, commerce co-op

* Tuesday, December 3, 2019 - Monday classes will be held
** Monday, April 6, 2020 - Friday classes will be held
General Information

Definitions

Definitions

The following definitions are intended to facilitate an understanding of the calendar and not to define all words and phrases used in the calendar which may have specific meanings.
Academic Dismissal

A student’s required withdrawal from a program due to unsatisfactory academic performance.
Academic Program

A distinct group of courses and other requirements which lead to eligibility for a degree or other university-awarded credential.
Academic Terms

• Fall term: September - December
• Winter term: January - April
• Summer term: May - August
• Regular term: September - April

Advanced Standing

Students possessing advanced knowledge of a subject will be encouraged to begin their studies in that subject at a level appropriate to their knowledge, as determined by the department/school/college concerned. However, such students must complete the full number of credit hours required for the particular credential being sought.
Audit Student

A student permitted to attend courses but not expected to prepare assignments, write papers, tests or examinations. Credit is not given nor is a mark awarded for courses. Courses appear on the transcript with the notation "Aud". If not already admitted to the University, audit students must apply. Students may register to audit a course only after the first day of courses.
Candidate

The term candidate for a doctoral degree is used to identify a student who has fulfilled all the requirements for the PhD except for the submission and defence of the thesis; thus, a candidate will have successfully completed the residency requirement, all course work, qualifying and comprehensive examinations (as applicable), and the thesis proposal defence (if applicable). This status is equivalent to the common terms "all but the thesis" or "all but dissertation" used at some institutions. The term candidate cannot be employed with regard to a Masters degree student.
Clerkship

See Internship
Clinical Practice

Not sure how helpful that is, I can't see a way to upload a word file. The Heading 2 headers are appearing the same as Heading 3 headers in the sample above.

Would it be possible to alter my code so it performs the macro on 50 pages at a time and keeps cycling through the document as a means to slow it down or prevent it from locking up?

Try

Code:

---

Sub RemoveHeadingsWithNoContent()
Dim oRng As Range
Set oRng = ActiveDocument.Range
  With oRng.Find
    .Style = "Heading 2"
    .Forward = True
    .Wrap = wdFindStop
    Do While .Execute
      If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
      If oRng.Paragraphs(1).Next.Range.Style <> "Normal" Then
        oRng.Delete
      End If
      DoEvents
    Loop
  End With
lbl_Exit:
  Exit Sub
End Sub

---

Thank you! Your code runs a lot cleaner than mine gmaxey. It will run without crashing Word, but it does appear to get into a never ending loop. With Word still running this at least allows me the ability to test further. I suspect something in the doc is keeping the code from finishing as expected.

Maybe this will help identify the problem:

Code:

---

Sub RemoveHeadingsWithNoContent()
Dim oRng As Range
Dim lngCount As Long
Set oRng = ActiveDocument.Range
  With oRng.Find
    .Style = "Heading 2"
    .Forward = True
    .Wrap = wdFindStop
    Do While .Execute
      lngCount = lngCount + 1
      If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
      If lngCount = ActiveDocument.Range.Paragraphs.Count Then
        oRng.Select
        Exit Do
      End If
      If oRng.Paragraphs(1).Next.Range.Style <> "Normal" Then
        oRng.Delete
      End If
      DoEvents
    Loop
  End With
lbl_Exit:
  Exit Sub
End Sub

---

This one works pretty good but if there is any place in your document where "heading 2" is the style of 4 paragraphs in a row. Like when you have two in a row in your original and they double up you will lose both of the second lines:

A
A
B
B

you'll be left with:
A

B is entirely lost.

Code:

---

Sub RemoveRepeatingHeadings()
Dim oRng As Range
Set oRng = ActiveDocument.Range
  With oRng.Find
    .Style = "Heading 2"
    .Forward = True
    .Wrap = wdFindStop
    Do While .Execute
      If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
      If oRng.Paragraphs(1).Range.Style = "Heading 2" _
      And oRng.Paragraphs(1).Next.Range.Style = "Heading 2" Then
      If oRng.Paragraphs(1).Next.Range.Style <> "normal" Then
    oRng.Paragraphs(1).Next.Range.Delete
    '  oRng.Delete
      End If
      End If
      'End If
      DoEvents
    Loop
  End With
lbl_Exit:
  Exit Sub
End Sub

---

Running a code that would change the style of a blank paragraphs that are heading 2 to normal first would fix this?

I think I read the requirement wrong earlier. You want do delete consecutive Heading 2 text and Heading 2 paragraphs that have no content correct? Try:

Code:

---

Sub RemoveHeadingsWithNoContent()
Dim oRng As Range
Dim lngCount As Long, lngPCount As Long
 
  lngPCount = ActiveDocument.Range.Paragraphs.Count
  Set oRng = ActiveDocument.Range
  With oRng.Find
    .Style = "Heading 2"
    .Forward = True
    .Wrap = wdFindStop
    Do While .Execute
      lngCount = lngCount + 1
      If oRng.Paragraphs(1).Range.End = ActiveDocument.Paragraphs.Last.Range.End Then Exit Do
      If lngCount = lngPCount Then
        oRng.Select
        Exit Do
      End If
      If oRng.Paragraphs(1).Next.Range.Style = "Heading 2" And _
        oRng.Paragraphs(1).Range.Text = oRng.Paragraphs(1).Next.Range.Text _
        Or oRng.Paragraphs(1).Next.Range.Style = "Heading 2" And Len(oRng.Paragraphs(1).Range.Text) = 1 Then
        oRng.Delete
      End If
      DoEvents
    Loop
  End With
lbl_Exit:

---

So if all this text was Heading 2

A
A
B

C
C

You are left with:

A
B
C

Thank you so much to both of you. The final version that gmaxey posted runs and finishes, but doesn't seem to remove any of the headings I'm trying to remove. The slightly modified version of gmaxey's code that Kilroy posted seems to do exactly what I was hoping it would.

Thanks again, you have no idea how much work this is going to save me.

What do you think was the main issue with my original script? If it's not too much trouble, I'm hoping to learn from this experience lol.

Astoneil I ran Gregs code on the sample provided and it worked perfectly. What is remaining that shouldn't be?

It doesn't seem to remove anything, although I had to add End Sub at the bottom for the code to work. Am I missing anything else?

Quote:

---

but doesn't seem to remove any of the headings I'm trying to remove.

---

What is remaining hat shouldn't?

Quote:

---

Originally Posted by Kilroy

What is remaining hat shouldn't?

---

The document appears to be unchanged after running Greg's code.

Kilroy has been very helpful by allowing me to share files and email with them about this. I'm now finding that my Word macros are responding differently than theirs given seemingly exactly the same parameters. I'm going to try more things on my end, and try testing with a different computer if needed. You've both given me a wealth of information and I'm very thankful.