Large Word Doc with many Duplicate Headings

[Astroneil]

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:


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.

[Kilroy]

Can you attach a small sample?

[Astroneil]

Academic Dates 2019/2020Academic Dates 2019/2020ACADEMIC 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 InformationDefinitionsDefinitionsThe 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 DismissalA student’s required withdrawal from a program due to unsatisfactory academic performance.
Academic ProgramA 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 StandingStudents 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 StudentA 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.
CandidateThe 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.
ClerkshipSee Internship
Clinical Practice

[Astroneil]

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.

[Astroneil]

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?

[gmaxey]

Try

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

[Astroneil]

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.

[gmaxey]

Maybe this will help identify the problem:


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

[Kilroy]

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.


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?

[gmaxey]

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:


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

[Astroneil]

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.

[Astroneil]

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.

[Kilroy]

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

[Astroneil]

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?

[Kilroy]

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

What is remaining hat shouldn't?

[Astroneil]

What is remaining hat shouldn't?

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

[Astroneil]

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.